- opengl demos from ypsilon (gears and glut-demo) now work under
ikarus's ffi using a compatibility layer.
This commit is contained in:
Abdulaziz Ghuloum
parent
abe97b4053
commit
61ecbe0dd1
|
|
@ -0,0 +1,283 @@
|
||||||
|
|
||||||
|
(library (core)
|
||||||
|
(export iota string-contains architecture-feature format
|
||||||
|
flonum->float string->cstring load-shared-object
|
||||||
|
lookup-shared-object
|
||||||
|
stdcall-shared-object->void
|
||||||
|
stdcall-shared-object->int
|
||||||
|
stdcall-shared-object->intptr
|
||||||
|
stdcall-shared-object->double
|
||||||
|
make-callback
|
||||||
|
usleep microsecond)
|
||||||
|
(import (except (ikarus) library format)
|
||||||
|
(except (ikarus system $foreign) make-callback))
|
||||||
|
|
||||||
|
(define (format what str . args)
|
||||||
|
(import (ikarus))
|
||||||
|
(cond
|
||||||
|
[(eq? what #f)
|
||||||
|
(apply printf str args)]
|
||||||
|
[else
|
||||||
|
(apply format str args)]))
|
||||||
|
|
||||||
|
(define (iota n i)
|
||||||
|
(cond
|
||||||
|
[(= n 0) '()]
|
||||||
|
[else (cons i (iota (- n 1) (+ i 1)))]))
|
||||||
|
|
||||||
|
(define (architecture-feature what)
|
||||||
|
(case what
|
||||||
|
[(operating-system) "darwin"]
|
||||||
|
[(alignof:int) 4]
|
||||||
|
[(sizeof:int) 4]
|
||||||
|
[else (error 'architecture-feature "invalid args" what)]))
|
||||||
|
|
||||||
|
(define (string-contains text s)
|
||||||
|
(define (starts-at? i)
|
||||||
|
(let f ([i i] [j 0])
|
||||||
|
(cond
|
||||||
|
[(= j (string-length s)) #t]
|
||||||
|
[(= i (string-length text)) #f]
|
||||||
|
[else
|
||||||
|
(and (char=? (string-ref text i) (string-ref s j))
|
||||||
|
(f (+ i 1) (+ j 1)))])))
|
||||||
|
(let f ([i 0])
|
||||||
|
(cond
|
||||||
|
[(= i (string-length text)) #f]
|
||||||
|
[(starts-at? i) #t]
|
||||||
|
[else (f (+ i 1))])))
|
||||||
|
|
||||||
|
(define-record-type library (fields name pointer))
|
||||||
|
|
||||||
|
(define (load-shared-object libname)
|
||||||
|
(make-library libname
|
||||||
|
(or (dlopen libname)
|
||||||
|
(error 'load-shared-object (dlerror) libname))))
|
||||||
|
|
||||||
|
(define-record-type shared-object
|
||||||
|
(fields name lib [mutable proc] pointer))
|
||||||
|
|
||||||
|
(define (lookup-shared-object lib name)
|
||||||
|
(define who 'lookup-shared-object)
|
||||||
|
(unless (symbol? name) (die who "not a symbol" name))
|
||||||
|
(unless (library? lib) (die who "not a library" lib))
|
||||||
|
(make-shared-object name lib #f
|
||||||
|
(or (dlsym (library-pointer lib) (symbol->string name))
|
||||||
|
(error who
|
||||||
|
(format #f "cannot find object ~a in library ~a"
|
||||||
|
name (library-name lib))))))
|
||||||
|
|
||||||
|
|
||||||
|
(define get-ffi
|
||||||
|
(let ([ffis '()])
|
||||||
|
(lambda (return-type arg-types)
|
||||||
|
(let ([x (cons return-type arg-types)])
|
||||||
|
(cond
|
||||||
|
[(assoc x ffis) => cdr]
|
||||||
|
[else
|
||||||
|
(let ([ffi (make-ffi return-type arg-types)])
|
||||||
|
(set! ffis (cons (cons x ffi) ffis))
|
||||||
|
ffi)])))))
|
||||||
|
|
||||||
|
(define (arg->arg-type who)
|
||||||
|
(define (err who x)
|
||||||
|
(error 'arg->arg-type
|
||||||
|
(format #f "cannot handle conversion for procedure ~a" who)
|
||||||
|
x))
|
||||||
|
(lambda (arg)
|
||||||
|
(cond
|
||||||
|
[(bytevector? arg) 'pointer]
|
||||||
|
[(vector? arg) 'pointer]
|
||||||
|
[(cstring? arg) 'pointer]
|
||||||
|
[(pointer? arg) 'pointer]
|
||||||
|
[(cfloat? arg) 'float]
|
||||||
|
[(flonum? arg) 'double]
|
||||||
|
[(or (fixnum? arg) (bignum? arg)) 'sint32]
|
||||||
|
[else (err who arg)])))
|
||||||
|
|
||||||
|
|
||||||
|
(define (convert-incoming type result)
|
||||||
|
(define who 'convert-incoming)
|
||||||
|
(case type
|
||||||
|
[(void) (void)]
|
||||||
|
[(sint32) result]
|
||||||
|
[(pointer) result]
|
||||||
|
[else (error who "unhandled type" type)]))
|
||||||
|
|
||||||
|
(define (convert-outgoing type arg)
|
||||||
|
(define who 'convert-outgoing)
|
||||||
|
(case type
|
||||||
|
[(pointer)
|
||||||
|
(cond
|
||||||
|
[(bytevector? arg) (bytevector->blob arg)]
|
||||||
|
[(vector? arg) (vector->blob arg)]
|
||||||
|
[(cstring? arg) (cstring-pointer arg)]
|
||||||
|
[(pointer? arg) arg]
|
||||||
|
[else (error who "no converter for" type arg)])]
|
||||||
|
[(sint32)
|
||||||
|
(cond
|
||||||
|
[(or (fixnum? arg) (bignum? arg)) arg]
|
||||||
|
[else (error who "no converter for" type arg)])]
|
||||||
|
[(float)
|
||||||
|
(cond
|
||||||
|
[(cfloat? arg) (cfloat-value arg)]
|
||||||
|
[else (error who "no converter for" type arg)])]
|
||||||
|
[(double)
|
||||||
|
(cond
|
||||||
|
[(flonum? arg) arg]
|
||||||
|
[else (error who "no converter for" type arg)])]
|
||||||
|
[else (error who "unhandled type" type)]))
|
||||||
|
|
||||||
|
(define (wrap-conversion who return-type arg-types f)
|
||||||
|
(lambda args
|
||||||
|
(unless (= (length args) (length arg-types))
|
||||||
|
(error who "incorrect number of arguments" args))
|
||||||
|
(let ([args (map convert-outgoing arg-types args)])
|
||||||
|
(let ([result (apply f args)])
|
||||||
|
(convert-incoming return-type result)))))
|
||||||
|
|
||||||
|
|
||||||
|
(define (make-proc who obj return-type args)
|
||||||
|
(let ([arg-types (map (arg->arg-type who) args)])
|
||||||
|
(let ([ffi (get-ffi return-type arg-types)])
|
||||||
|
(wrap-conversion
|
||||||
|
(shared-object-name obj)
|
||||||
|
return-type arg-types
|
||||||
|
(ffi (shared-object-pointer obj))))))
|
||||||
|
|
||||||
|
|
||||||
|
(define (get-proc who obj return-type args)
|
||||||
|
(unless (shared-object? obj)
|
||||||
|
(error who "not a shared object" obj))
|
||||||
|
(or (shared-object-proc obj)
|
||||||
|
(let ([p (make-proc who obj return-type args)])
|
||||||
|
(shared-object-proc-set! obj p)
|
||||||
|
p)))
|
||||||
|
|
||||||
|
|
||||||
|
(define-record-type cstring (fields pointer))
|
||||||
|
|
||||||
|
|
||||||
|
(define (string->cstring str)
|
||||||
|
(let ([bv (string->utf8 str)])
|
||||||
|
(let ([n (bytevector-length bv)])
|
||||||
|
(let ([p (malloc (+ n 1))])
|
||||||
|
(let f ([i 0])
|
||||||
|
(unless (= i n)
|
||||||
|
(pointer-set-char p i (bytevector-u8-ref bv i))
|
||||||
|
(f (+ i 1))))
|
||||||
|
(pointer-set-char p n 0)
|
||||||
|
(make-cstring p)))))
|
||||||
|
|
||||||
|
|
||||||
|
(define (bytevector->blob bv)
|
||||||
|
(let ([n (bytevector-length bv)])
|
||||||
|
(let ([p (malloc n)])
|
||||||
|
(let f ([i 0] [j (- n 1)])
|
||||||
|
(unless (= i n)
|
||||||
|
(pointer-set-char p i (bytevector-u8-ref bv j))
|
||||||
|
(f (+ i 1) (- j 1))))
|
||||||
|
p)))
|
||||||
|
|
||||||
|
|
||||||
|
#;
|
||||||
|
(define (bytevector->blob bv)
|
||||||
|
(let ([n (bytevector-length bv)])
|
||||||
|
(let ([p (malloc n)])
|
||||||
|
(let f ([i 0])
|
||||||
|
(unless (= i n)
|
||||||
|
(pointer-set-char p i (bytevector-u8-ref bv i))
|
||||||
|
(f (+ i 1))))
|
||||||
|
p)))
|
||||||
|
|
||||||
|
|
||||||
|
(define (object->long x)
|
||||||
|
(cond
|
||||||
|
[(integer? x) x]
|
||||||
|
[(cstring? x) (pointer->integer (cstring-pointer x))]
|
||||||
|
[else (error 'object->pointer "cannot handle" x)]))
|
||||||
|
|
||||||
|
(define (vector->blob v)
|
||||||
|
(let ([n (vector-length v)])
|
||||||
|
(let ([p (malloc (* n 4))])
|
||||||
|
(let f ([i 0] [j (- n 1)])
|
||||||
|
(unless (= i n)
|
||||||
|
(pointer-set-long p (* i 4)
|
||||||
|
(object->long (vector-ref v j)))
|
||||||
|
(f (+ i 1) (- j 1))))
|
||||||
|
p)))
|
||||||
|
|
||||||
|
(define-record-type cfloat (fields value))
|
||||||
|
|
||||||
|
(define (flonum->float x)
|
||||||
|
(cond
|
||||||
|
[(flonum? x) (make-cfloat x)]
|
||||||
|
[else (error 'flonum->float "invalid arg" x)]))
|
||||||
|
|
||||||
|
|
||||||
|
(define (stdcall-shared-object->void proc . args)
|
||||||
|
(apply (get-proc 'stdcall-shared-object->void proc 'void args) args))
|
||||||
|
|
||||||
|
|
||||||
|
(define (stdcall-shared-object->int proc . args)
|
||||||
|
(apply (get-proc 'stdcall-shared-object->int proc 'sint32 args) args))
|
||||||
|
|
||||||
|
(define (stdcall-shared-object->intptr proc . args)
|
||||||
|
(apply (get-proc 'stdcall-shared-object->intptr proc 'pointer args) args))
|
||||||
|
|
||||||
|
(define (make-callback conv argcount proc)
|
||||||
|
(import (ikarus system $foreign))
|
||||||
|
(define who 'make-callback)
|
||||||
|
(unless (procedure? proc) (error who "not a procedure" proc))
|
||||||
|
(unless (eqv? 0 conv) (error who "invalid calling convention" conv))
|
||||||
|
((make-callback 'sint32 (make-list argcount 'sint32)) proc))
|
||||||
|
|
||||||
|
|
||||||
|
(define (stdcall-shared-object->double . args) (error '#f "invalid args" args))
|
||||||
|
(define (usleep . args) (error '#f "invalid args" args))
|
||||||
|
|
||||||
|
(define (microsecond)
|
||||||
|
(let ([t (current-time)])
|
||||||
|
(+ (* (time-second t) 1000000)
|
||||||
|
(div (time-nanosecond t) 1000))))
|
||||||
|
|
||||||
|
;(define-record-type carray (fields pointer))
|
||||||
|
|
||||||
|
;(define make-binary-array-of-int
|
||||||
|
; (lambda argv
|
||||||
|
; (let ((step (architecture-feature 'alignof:int))
|
||||||
|
; (proc (case (architecture-feature 'sizeof:int)
|
||||||
|
; ((4) pointer-set-int)
|
||||||
|
; ((8) pointer-set-long)
|
||||||
|
; (else
|
||||||
|
; (syntax-violation 'make-binary-array-of-int "byte size of int not defined")))))
|
||||||
|
; (let ((p (malloc (* step (length argv)))))
|
||||||
|
; (let loop ((offset 0) (arg argv))
|
||||||
|
; (cond ((null? arg) (make-carray p))
|
||||||
|
; (else
|
||||||
|
; (let ((value (car arg)))
|
||||||
|
; (proc p offset value)
|
||||||
|
; (loop (+ offset step) (cdr arg))))))))))
|
||||||
|
;
|
||||||
|
|
||||||
|
;(define make-binary-array-of-char*
|
||||||
|
; (lambda (ref . argv)
|
||||||
|
; (assert (= ref 0))
|
||||||
|
; (let ((step (architecture-feature 'alignof:int))
|
||||||
|
; (proc (case (architecture-feature 'sizeof:int)
|
||||||
|
; ((4) pointer-set-int)
|
||||||
|
; ((8) pointer-set-long)
|
||||||
|
; (else
|
||||||
|
; (syntax-violation 'make-binary-array-of-char* "byte size of int not defined")))))
|
||||||
|
; (let ((p (malloc (* step (length argv)))))
|
||||||
|
; (let loop ((offset 0) (arg argv))
|
||||||
|
; (cond ((null? arg) (make-carray p))
|
||||||
|
; (else
|
||||||
|
; (let ((value (car arg)))
|
||||||
|
; (proc p offset
|
||||||
|
; (pointer->integer
|
||||||
|
; (cstring-pointer (string->cstring value))))
|
||||||
|
; (loop (+ offset step) (cdr arg))))))))))
|
||||||
|
|
||||||
|
)
|
||||||
|
|
||||||
|
|
@ -0,0 +1,196 @@
|
||||||
|
;;; Ypsilon Scheme System
|
||||||
|
;;; Copyright (c) 2004-2008 Y.FUJITA, LittleWing Company Limited.
|
||||||
|
;;; See license.txt for terms and conditions of use.
|
||||||
|
|
||||||
|
(library (ffi)
|
||||||
|
|
||||||
|
(export c-function c-argument
|
||||||
|
on-windows on-darwin on-linux on-freebsd on-posix)
|
||||||
|
|
||||||
|
(import (rnrs) (core))
|
||||||
|
|
||||||
|
(define on-windows (and (string-contains (architecture-feature 'operating-system) "windows") #t))
|
||||||
|
(define on-darwin (and (string-contains (architecture-feature 'operating-system) "darwin") #t))
|
||||||
|
(define on-linux (and (string-contains (architecture-feature 'operating-system) "linux") #t))
|
||||||
|
(define on-freebsd (and (string-contains (architecture-feature 'operating-system) "freebsd") #t))
|
||||||
|
(define on-posix (not on-windows))
|
||||||
|
|
||||||
|
(define assert-bool
|
||||||
|
(lambda (name n i)
|
||||||
|
(cond ((boolean? i) (if i 1 0))
|
||||||
|
(else
|
||||||
|
(assertion-violation name (format "expected #t or #f, but got ~r, as argument ~s" i n))))))
|
||||||
|
|
||||||
|
(define assert-int
|
||||||
|
(lambda (name n i)
|
||||||
|
(cond ((and (integer? i) (exact? i)) i)
|
||||||
|
(else
|
||||||
|
(assertion-violation name (format "expected exact integer, but got ~r, as argument ~s" i n))))))
|
||||||
|
|
||||||
|
(define assert-float
|
||||||
|
(lambda (name n f)
|
||||||
|
(cond ((flonum? f) (flonum->float f))
|
||||||
|
(else
|
||||||
|
(assertion-violation name (format "expected flonum, but got ~r, as argument ~s" f n))))))
|
||||||
|
|
||||||
|
(define assert-double
|
||||||
|
(lambda (name n f)
|
||||||
|
(cond ((flonum? f) f)
|
||||||
|
(else
|
||||||
|
(assertion-violation name (format "expected flonum, but got ~r, as argument ~s" f n))))))
|
||||||
|
|
||||||
|
(define assert-string
|
||||||
|
(lambda (name n s)
|
||||||
|
(cond ((string? s) s)
|
||||||
|
(else
|
||||||
|
(assertion-violation name (format "expected string, but got ~r, as argument ~s" s n))))))
|
||||||
|
|
||||||
|
(define assert-bytevector
|
||||||
|
(lambda (name n b)
|
||||||
|
(cond ((bytevector? b) b)
|
||||||
|
(else
|
||||||
|
(assertion-violation name (format "expected bytevector, but got ~r, as argument ~s" b n))))))
|
||||||
|
|
||||||
|
(define assert-closure
|
||||||
|
(lambda (name n p)
|
||||||
|
(cond ((procedure? p) p)
|
||||||
|
(else
|
||||||
|
(assertion-violation name (format "expected procedure, but got ~r, as argument ~s" p n))))))
|
||||||
|
|
||||||
|
(define assert-int-vector
|
||||||
|
(lambda (name n vect)
|
||||||
|
(or (vector? vect)
|
||||||
|
(assertion-violation name (format "expected vector, but got ~r, as argument ~s" vect n)))
|
||||||
|
(let ((lst (vector->list vect)))
|
||||||
|
(for-each (lambda (i)
|
||||||
|
(or (and (integer? i) (exact? i))
|
||||||
|
(assertion-violation name (format "expected list of exact integer, but got ~r, as argument ~s" vect n))))
|
||||||
|
lst)
|
||||||
|
lst)))
|
||||||
|
|
||||||
|
(define assert-string-vector
|
||||||
|
(lambda (name n vect)
|
||||||
|
(or (vector? vect)
|
||||||
|
(assertion-violation name (format "expected vector, but got ~r, as argument ~s" vect n)))
|
||||||
|
(let ((lst (vector->list vect)))
|
||||||
|
(for-each (lambda (s)
|
||||||
|
(or (string? s)
|
||||||
|
(assertion-violation name (format "expected vector of string, but got ~r, as argument ~s" vect n))))
|
||||||
|
lst)
|
||||||
|
lst)))
|
||||||
|
|
||||||
|
(define int->bool
|
||||||
|
(lambda (val)
|
||||||
|
(not (= val 0))))
|
||||||
|
|
||||||
|
(define char*->string
|
||||||
|
(lambda (val)
|
||||||
|
(and val (bytevector->string val (make-transcoder (utf-8-codec))))))
|
||||||
|
|
||||||
|
(define make-binary-array-of-int
|
||||||
|
(lambda argv
|
||||||
|
(let ((step (architecture-feature 'alignof:int))
|
||||||
|
(proc (case (architecture-feature 'sizeof:int)
|
||||||
|
((4) bytevector-s32-native-set!)
|
||||||
|
((8) bytevector-s64-native-set!)
|
||||||
|
(else
|
||||||
|
(syntax-violation 'make-binary-array-of-int "byte size of int not defined")))))
|
||||||
|
(let ((bv (make-bytevector (* step (length argv)))))
|
||||||
|
(let loop ((offset 0) (arg argv))
|
||||||
|
(cond ((null? arg) bv)
|
||||||
|
(else
|
||||||
|
(let ((value (car arg)))
|
||||||
|
(proc bv offset value)
|
||||||
|
(loop (+ offset step) (cdr arg))))))))))
|
||||||
|
|
||||||
|
(define make-binary-array-of-char*
|
||||||
|
(lambda (ref . argv)
|
||||||
|
(apply vector
|
||||||
|
ref
|
||||||
|
(map (lambda (value) (string->cstring value)) argv))))
|
||||||
|
|
||||||
|
(define-syntax c-callback-arguments
|
||||||
|
(lambda (x)
|
||||||
|
(syntax-case x ()
|
||||||
|
((_ args ...)
|
||||||
|
(let ((lst (syntax->datum (syntax (args ...)))))
|
||||||
|
(if (for-all (lambda (arg) (memq arg '(int void*))) lst)
|
||||||
|
(datum->syntax #'k (length lst))
|
||||||
|
(syntax-violation 'c-callback "expected list of int or void* for argument" x)))))))
|
||||||
|
|
||||||
|
(define-syntax c-argument
|
||||||
|
(syntax-rules (int bool void* char* byte* double float c-callback __stdcall)
|
||||||
|
((_ name n int var)
|
||||||
|
(assert-int 'name n var))
|
||||||
|
((_ name n bool var)
|
||||||
|
(assert-bool 'name n var))
|
||||||
|
((_ name n void* var)
|
||||||
|
(assert-int 'name n var))
|
||||||
|
((_ name n float var)
|
||||||
|
(assert-float 'name n var))
|
||||||
|
((_ name n double var)
|
||||||
|
(assert-double 'name n var))
|
||||||
|
((_ name n byte* var)
|
||||||
|
(assert-bytevector 'name n var))
|
||||||
|
((_ name n char* var)
|
||||||
|
(string->cstring (assert-string 'name n var)))
|
||||||
|
((_ name n [int] var)
|
||||||
|
(apply make-binary-array-of-int (assert-int-vector 'name n var)))
|
||||||
|
((_ name n [char*] var)
|
||||||
|
(apply make-binary-array-of-char* 0 (assert-string-vector 'name n var)))
|
||||||
|
((_ name n (*[char*]) var)
|
||||||
|
(apply make-binary-array-of-char* 1 (assert-string-vector 'name n var)))
|
||||||
|
((_ name n [c-callback void (args ...)] var)
|
||||||
|
(make-callback 0 (c-callback-arguments args ...) (assert-closure 'name n var)))
|
||||||
|
((_ name n [c-callback int (args ...)] var)
|
||||||
|
(make-callback 0 (c-callback-arguments args ...) (assert-closure 'name n var)))
|
||||||
|
((_ name n [c-callback void __stdcall (args ...)] var)
|
||||||
|
(make-callback 1 (c-callback-arguments args ...) (assert-closure 'name n var)))
|
||||||
|
((_ name n [c-callback int __stdcall (args ...)] var)
|
||||||
|
(make-callback 1 (c-callback-arguments args ...) (assert-closure 'name n var)))))
|
||||||
|
|
||||||
|
(define-syntax c-function-stub
|
||||||
|
(lambda (x)
|
||||||
|
(syntax-case x ()
|
||||||
|
((_ lib-handle lib-name (cast stub) func-name types ...)
|
||||||
|
(with-syntax (((args ...) (generate-temporaries (syntax (types ...))))
|
||||||
|
((n ...) (map (lambda (e) (datum->syntax #'k e)) (iota (length (syntax (types ...))) 1))))
|
||||||
|
(syntax (let ((loc (lookup-shared-object lib-handle 'func-name)))
|
||||||
|
(if loc
|
||||||
|
(let () (define func-name
|
||||||
|
(lambda (args ...)
|
||||||
|
(cast (stub loc (c-argument func-name n types args) ...)))) func-name)
|
||||||
|
(let () (define func-name
|
||||||
|
(lambda x
|
||||||
|
(error 'func-name (format "function not available in ~a" lib-name)))) func-name))))))
|
||||||
|
((_ lib-handle lib-name stub func-name types ...)
|
||||||
|
(syntax (c-function-stub lib-handle lib-name ((lambda (x) x) stub) func-name types ...))))))
|
||||||
|
|
||||||
|
(define-syntax c-function
|
||||||
|
(syntax-rules (__stdcall void int double void* bool char*)
|
||||||
|
((_ lib-handle lib-name void __stdcall func-name (types ...))
|
||||||
|
(c-function-stub lib-handle lib-name stdcall-shared-object->void func-name types ...))
|
||||||
|
((_ lib-handle lib-name int __stdcall func-name (types ...))
|
||||||
|
(c-function-stub lib-handle lib-name stdcall-shared-object->int func-name types ...))
|
||||||
|
((_ lib-handle lib-name double __stdcall func-name (types ...))
|
||||||
|
(c-function-stub lib-handle lib-name stdcall-shared-object->double func-name types ...))
|
||||||
|
((_ lib-handle lib-name void* __stdcall func-name (types ...))
|
||||||
|
(c-function-stub lib-handle lib-name stdcall-shared-object->intptr func-name types ...))
|
||||||
|
((_ lib-handle lib-name bool __stdcall func-name (types ...))
|
||||||
|
(c-function-stub lib-handle lib-name (int->bool stdcall-shared-object->int) func-name types ...))
|
||||||
|
((_ lib-handle lib-name char* __stdcall func-name (types ...))
|
||||||
|
(c-function-stub lib-handle lib-name (char*->string stdcall-shared-object->char*) func-name types ...))
|
||||||
|
((_ lib-handle lib-name void func-name (types ...))
|
||||||
|
(c-function-stub lib-handle lib-name call-shared-object->void func-name types ...))
|
||||||
|
((_ lib-handle lib-name int func-name (types ...))
|
||||||
|
(c-function-stub lib-handle lib-name call-shared-object->int func-name types ...))
|
||||||
|
((_ lib-handle lib-name double func-name (types ...))
|
||||||
|
(c-function-stub lib-handle lib-name call-shared-object->double func-name types ...))
|
||||||
|
((_ lib-handle lib-name void* func-name (types ...))
|
||||||
|
(c-function-stub lib-handle lib-name call-shared-object->intptr func-name types ...))
|
||||||
|
((_ lib-handle lib-name bool func-name (types ...))
|
||||||
|
(c-function-stub lib-handle lib-name (int->bool call-shared-object->int) func-name types ...))
|
||||||
|
((_ lib-handle lib-name char* func-name (types ...))
|
||||||
|
(c-function-stub lib-handle lib-name (char*->string call-shared-object->char*) func-name types ...))))
|
||||||
|
|
||||||
|
) ;[end]
|
||||||
|
|
@ -0,0 +1,350 @@
|
||||||
|
#!/usr/bin/env ypsilon
|
||||||
|
;;
|
||||||
|
;; 3-D gear wheels. This program is in the public domain.
|
||||||
|
;;
|
||||||
|
;; Brian Paul
|
||||||
|
;;
|
||||||
|
;; Conversion to GLUT by Mark J. Kilgard
|
||||||
|
;; Conversion to GtkGLExt by Naofumi Yasufuku
|
||||||
|
;; Port to Scheme/Gauche(GtkGLExt) by Shiro Kawai
|
||||||
|
;; Port to Scheme/Gauche(GLUT) by YOKOTA Hiroshi
|
||||||
|
;; Port to Ypsilon by YOKOTA Hiroshi
|
||||||
|
|
||||||
|
(import (core) (rnrs) (rnrs programs) (gl) (glut))
|
||||||
|
|
||||||
|
;; These constant values are not defined in Ypsilon yet
|
||||||
|
(define pi 3.14159265358979323846)
|
||||||
|
(define GLUT_ELAPSED_TIME 700)
|
||||||
|
|
||||||
|
(define (f32vector . lst)
|
||||||
|
(define-syntax f32set!
|
||||||
|
(syntax-rules ()
|
||||||
|
((_ bv n value)
|
||||||
|
(bytevector-ieee-single-native-set! bv (* n 4) value))))
|
||||||
|
(let ((bv (make-bytevector (* (length lst) 4))))
|
||||||
|
(let loop ((i 0) (lst lst))
|
||||||
|
(cond ((null? lst)
|
||||||
|
(u8-list->bytevector (reverse (bytevector->u8-list bv))))
|
||||||
|
(else
|
||||||
|
(f32set! bv i (car lst))
|
||||||
|
(loop (+ i 1) (cdr lst)))))))
|
||||||
|
|
||||||
|
(define (/. a b)
|
||||||
|
(/ (inexact a) (inexact b)))
|
||||||
|
|
||||||
|
(define (c-int->c-uchar c)
|
||||||
|
(bitwise-and c #xff))
|
||||||
|
|
||||||
|
;; Draw a gear wheel. You'll probably want to call this function when
|
||||||
|
;; building a display list since we do a lot of trig here.
|
||||||
|
;;
|
||||||
|
;; Input: inner_radius - radius of hole at center
|
||||||
|
;; outer_radius - radius at center of teeth
|
||||||
|
;; width - width of gear
|
||||||
|
;; teeth - number of teeth
|
||||||
|
;; tooth_depth - depth of tooth
|
||||||
|
|
||||||
|
(define (gear inner-radius outer-radius width teeth tooth-depth)
|
||||||
|
(let ((r0 inner-radius)
|
||||||
|
(r1 (- outer-radius (/ tooth-depth 2.0)))
|
||||||
|
(r2 (+ outer-radius (/ tooth-depth 2.0)))
|
||||||
|
(da (* 2.0 (/ pi teeth 4.0))))
|
||||||
|
(glShadeModel GL_FLAT)
|
||||||
|
(glNormal3f 0.0 0.0 1.0)
|
||||||
|
|
||||||
|
;; draw front face
|
||||||
|
(glBegin GL_QUAD_STRIP)
|
||||||
|
(do ((i 0.0 (+ i 1.0))) ((>= i (+ teeth 1.0)))
|
||||||
|
(let ((_angle (* i 2.0 (/ pi teeth))))
|
||||||
|
(glVertex3f (* r0 (cos _angle)) (* r0 (sin _angle)) (* width 0.5))
|
||||||
|
(glVertex3f (* r1 (cos _angle)) (* r1 (sin _angle)) (* width 0.5))
|
||||||
|
(when (< i teeth)
|
||||||
|
(glVertex3f (* r0 (cos _angle)) (* r0 (sin _angle)) (* width 0.5))
|
||||||
|
(glVertex3f (* r1 (cos (+ _angle (* 3.0 da))))
|
||||||
|
(* r1 (sin (+ _angle (* 3.0 da))))
|
||||||
|
(* width 0.5)))))
|
||||||
|
(glEnd)
|
||||||
|
|
||||||
|
;; draw front sides of teeth
|
||||||
|
(glBegin GL_QUADS)
|
||||||
|
(do ((i 0.0 (+ i 1.0))) ((>= i teeth))
|
||||||
|
(let ((_angle (* i 2.0 (/ pi teeth))))
|
||||||
|
(glVertex3f (* r1 (cos _angle)) (* r1 (sin _angle)) (* width 0.5))
|
||||||
|
(glVertex3f (* r2 (cos (+ _angle da)))
|
||||||
|
(* r2 (sin (+ _angle da)))
|
||||||
|
(* width 0.5))
|
||||||
|
(glVertex3f (* r2 (cos (+ _angle (* 2.0 da))))
|
||||||
|
(* r2 (sin (+ _angle (* 2.0 da))))
|
||||||
|
(* width 0.5))
|
||||||
|
(glVertex3f (* r1 (cos (+ _angle (* 3.0 da))))
|
||||||
|
(* r1 (sin (+ _angle (* 3.0 da))))
|
||||||
|
(* width 0.5))))
|
||||||
|
(glEnd)
|
||||||
|
|
||||||
|
(glNormal3f 0.0 0.0 -1.0)
|
||||||
|
|
||||||
|
;; draw back face
|
||||||
|
(glBegin GL_QUAD_STRIP)
|
||||||
|
(do ((i 0.0 (+ i 1.0))) ((>= i (+ teeth 1.0)))
|
||||||
|
(let ((_angle (* i 2.0 (/ pi teeth))))
|
||||||
|
(glVertex3f (* r1 (cos _angle)) (* r1 (sin _angle)) (* width -0.5))
|
||||||
|
(glVertex3f (* r0 (cos _angle)) (* r0 (sin _angle)) (* width -0.5))
|
||||||
|
(when (< i teeth)
|
||||||
|
(glVertex3f (* r1 (cos (+ _angle (* 3.0 da))))
|
||||||
|
(* r1 (sin (+ _angle (* 3.0 da))))
|
||||||
|
(* width -0.5))
|
||||||
|
(glVertex3f (* r0 (cos _angle)) (* r0 (sin _angle)) (* width -0.5)))))
|
||||||
|
(glEnd)
|
||||||
|
|
||||||
|
;; draw back sides of teeth
|
||||||
|
(glBegin GL_QUADS)
|
||||||
|
(do ((i 0.0 (+ i 1.0))) ((>= i teeth))
|
||||||
|
(let ((_angle (* i 2.0 (/ pi teeth))))
|
||||||
|
(glVertex3f (* r1 (cos (+ _angle (* 3.0 da))))
|
||||||
|
(* r1 (sin (+ _angle (* 3.0 da))))
|
||||||
|
(* width -0.5))
|
||||||
|
(glVertex3f (* r2 (cos (+ _angle (* 2.0 da))))
|
||||||
|
(* r2 (sin (+ _angle (* 2.0 da))))
|
||||||
|
(* width -0.5))
|
||||||
|
(glVertex3f (* r2 (cos (+ _angle da)))
|
||||||
|
(* r2 (sin (+ _angle da)))
|
||||||
|
(* width -0.5))
|
||||||
|
(glVertex3f (* r1 (cos _angle)) (* r1 (sin _angle)) (* width -0.5))))
|
||||||
|
(glEnd)
|
||||||
|
|
||||||
|
;; draw outward faces of teeth
|
||||||
|
(glBegin GL_QUAD_STRIP)
|
||||||
|
(do ((i 0.0 (+ i 1.0))) ((>= i teeth))
|
||||||
|
(let ((_angle (* i 2.0 (/ pi teeth)))
|
||||||
|
(u 0.0)
|
||||||
|
(v 0.0)
|
||||||
|
(len 0.0))
|
||||||
|
(glVertex3f (* r1 (cos _angle)) (* r1 (sin _angle)) (* width 0.5))
|
||||||
|
(glVertex3f (* r1 (cos _angle)) (* r1 (sin _angle)) (* width -0.5))
|
||||||
|
|
||||||
|
(set! u (- (* r2 (cos (+ _angle da))) (* r1 (cos _angle))))
|
||||||
|
(set! v (- (* r2 (sin (+ _angle da))) (* r1 (sin _angle))))
|
||||||
|
(set! len (sqrt (+ (* u u) (* v v))))
|
||||||
|
;; canonicalize normal vector
|
||||||
|
(set! u (/ u len))
|
||||||
|
(set! v (/ v len))
|
||||||
|
|
||||||
|
(glNormal3f v (- u) 0.0)
|
||||||
|
|
||||||
|
(glVertex3f (* r2 (cos (+ _angle da)))
|
||||||
|
(* r2 (sin (+ _angle da)))
|
||||||
|
(* width 0.5))
|
||||||
|
(glVertex3f (* r2 (cos (+ _angle da)))
|
||||||
|
(* r2 (sin (+ _angle da)))
|
||||||
|
(* width -0.5))
|
||||||
|
(glNormal3f (cos _angle) (sin _angle) 0.0)
|
||||||
|
(glVertex3f (* r2 (cos (+ _angle (* 2 da))))
|
||||||
|
(* r2 (sin (+ _angle (* 2 da))))
|
||||||
|
(* width 0.5))
|
||||||
|
(glVertex3f (* r2 (cos (+ _angle (* 2 da))))
|
||||||
|
(* r2 (sin (+ _angle (* 2 da))))
|
||||||
|
(* width -0.5))
|
||||||
|
|
||||||
|
(set! u (- (* r1 (cos (+ _angle (* 3 da))))
|
||||||
|
(* r2 (cos (+ _angle (* 2 da))))))
|
||||||
|
(set! v (- (* r1 (sin (+ _angle (* 3 da))))
|
||||||
|
(* r2 (sin (+ _angle (* 2 da))))))
|
||||||
|
|
||||||
|
(glNormal3f v (- u) 0.0)
|
||||||
|
|
||||||
|
(glVertex3f (* r1 (cos (+ _angle (* 3 da))))
|
||||||
|
(* r1 (sin (+ _angle (* 3 da))))
|
||||||
|
(* width 0.5))
|
||||||
|
(glVertex3f (* r1 (cos (+ _angle (* 3 da))))
|
||||||
|
(* r1 (sin (+ _angle (* 3 da))))
|
||||||
|
(* width -0.5))
|
||||||
|
(glNormal3f (cos _angle) (sin _angle) 0.0)))
|
||||||
|
(glVertex3f (* r1 (cos 0.0)) (* r1 (sin 0.0)) (* width 0.5))
|
||||||
|
(glVertex3f (* r1 (cos 0.0)) (* r1 (sin 0.0)) (* width -0.5))
|
||||||
|
(glEnd)
|
||||||
|
|
||||||
|
(glShadeModel GL_SMOOTH)
|
||||||
|
|
||||||
|
;; draw inside radius cylinder
|
||||||
|
(glBegin GL_QUAD_STRIP)
|
||||||
|
(do ((i 0.0 (+ i 1.0))) ((>= i (+ teeth 1.0)))
|
||||||
|
(let ((_angle (* i 2.0 (/ pi teeth))))
|
||||||
|
(glNormal3f (- (cos _angle)) (- (sin _angle)) 0.0)
|
||||||
|
(glVertex3f (* r0 (cos _angle)) (* r0 (sin _angle)) (* width -0.5))
|
||||||
|
(glVertex3f (* r0 (cos _angle)) (* r0 (sin _angle)) (* width 0.5))))
|
||||||
|
(glEnd)
|
||||||
|
))
|
||||||
|
|
||||||
|
(define *view-rotx* 20.0)
|
||||||
|
(define *view-roty* 30.0)
|
||||||
|
(define *view-rotz* 0.0)
|
||||||
|
(define *gear1* #f)
|
||||||
|
(define *gear2* #f)
|
||||||
|
(define *gear3* #f)
|
||||||
|
(define *angle* 0.0)
|
||||||
|
(define *frames* 0)
|
||||||
|
(define *t0* 0)
|
||||||
|
(define *win* #f)
|
||||||
|
|
||||||
|
(define (cleanup)
|
||||||
|
(glDeleteLists *gear1* 1)
|
||||||
|
(glDeleteLists *gear2* 1)
|
||||||
|
(glDeleteLists *gear3* 1)
|
||||||
|
(glutDestroyWindow *win*))
|
||||||
|
|
||||||
|
(define (draw)
|
||||||
|
;;*** OpenGL BEGIN ***
|
||||||
|
(glClear (bitwise-ior GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
|
||||||
|
(begin
|
||||||
|
(glPushMatrix)
|
||||||
|
(glRotatef *view-rotx* 1.0 0.0 0.0)
|
||||||
|
(glRotatef *view-roty* 0.0 1.0 0.0)
|
||||||
|
(glRotatef *view-rotz* 0.0 0.0 1.0)
|
||||||
|
(begin
|
||||||
|
(glPushMatrix)
|
||||||
|
(glTranslatef -3.0 -2.0 0.0)
|
||||||
|
(glRotatef *angle* 0.0 0.0 1.0)
|
||||||
|
(glCallList *gear1*)
|
||||||
|
(glPopMatrix))
|
||||||
|
(begin
|
||||||
|
(glPushMatrix)
|
||||||
|
(glTranslatef 3.1 -2.0 0.0)
|
||||||
|
(glRotatef (- (* -2.0 *angle*) 9.0) 0.0 0.0 1.0)
|
||||||
|
(glCallList *gear2*)
|
||||||
|
(glPopMatrix))
|
||||||
|
(begin
|
||||||
|
(glPushMatrix)
|
||||||
|
(glTranslatef -3.1 4.2 0.0)
|
||||||
|
(glRotatef (- (* -2.0 *angle*) 25.0) 0.0 0.0 1.0)
|
||||||
|
(glCallList *gear3*)
|
||||||
|
(glPopMatrix))
|
||||||
|
(glPopMatrix))
|
||||||
|
|
||||||
|
(glutSwapBuffers)
|
||||||
|
|
||||||
|
(set! *frames* (+ 1 *frames*))
|
||||||
|
|
||||||
|
(let ((t (glutGet GLUT_ELAPSED_TIME)))
|
||||||
|
(when (>= (- t *t0*) 5000)
|
||||||
|
(let ((seconds (/ (- t *t0*) 1000.0)))
|
||||||
|
(format #t "~d in ~d seconds = ~d FPS~%" *frames* seconds (/ *frames* seconds))
|
||||||
|
(set! *t0* t)
|
||||||
|
(set! *frames* 0)))))
|
||||||
|
|
||||||
|
;; new window size or exposure
|
||||||
|
(define (reshape width height)
|
||||||
|
(let ((h (/. height width)))
|
||||||
|
;;*** OpenGL BEGIN ***
|
||||||
|
(glViewport 0 0 width height)
|
||||||
|
(glMatrixMode GL_PROJECTION)
|
||||||
|
(glLoadIdentity)
|
||||||
|
(glFrustum -1.0 1.0 (- h) h 5.0 60.0)
|
||||||
|
(glMatrixMode GL_MODELVIEW)
|
||||||
|
(glLoadIdentity)
|
||||||
|
(glTranslatef 0.0 0.0 -40.0)
|
||||||
|
;;*** OpenGL END ***
|
||||||
|
))
|
||||||
|
|
||||||
|
(define (init)
|
||||||
|
;;*** OpenGL BEGIN ***
|
||||||
|
(glLightfv GL_LIGHT0 GL_POSITION (f32vector 5.0 5.0 10.0 0.0))
|
||||||
|
(glEnable GL_CULL_FACE)
|
||||||
|
(glEnable GL_LIGHTING)
|
||||||
|
(glEnable GL_LIGHT0)
|
||||||
|
(glEnable GL_DEPTH_TEST)
|
||||||
|
|
||||||
|
;; make the gears
|
||||||
|
(set! *gear1* (glGenLists 1))
|
||||||
|
(glNewList *gear1* GL_COMPILE)
|
||||||
|
(glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE (f32vector 0.8 0.1 0.0 1.0))
|
||||||
|
(gear 1.0 4.0 1.0 20 0.7)
|
||||||
|
(glEndList)
|
||||||
|
|
||||||
|
(set! *gear2* (glGenLists 1))
|
||||||
|
(glNewList *gear2* GL_COMPILE)
|
||||||
|
(glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE (f32vector 0.0 0.8 0.2 1.0))
|
||||||
|
(gear 0.5 2.0 2.0 10 0.7)
|
||||||
|
(glEndList)
|
||||||
|
|
||||||
|
(set! *gear3* (glGenLists 1))
|
||||||
|
(glNewList *gear3* GL_COMPILE)
|
||||||
|
(glMaterialfv GL_FRONT GL_AMBIENT_AND_DIFFUSE (f32vector 0.2 0.2 1.0 1.0))
|
||||||
|
(gear 1.3 2.0 0.5 10 0.7)
|
||||||
|
(glEndList)
|
||||||
|
|
||||||
|
(glEnable GL_NORMALIZE)
|
||||||
|
|
||||||
|
;; glGetString dose not works correctly.
|
||||||
|
(if (string? (glGetString GL_RENDERER))
|
||||||
|
(begin
|
||||||
|
(newline)
|
||||||
|
(format #t "GL_RENDERER = ~s~%" (glGetString GL_RENDERER))
|
||||||
|
(format #t "GL_VERSION = ~s~%" (glGetString GL_VERSION))
|
||||||
|
(format #t "GL_VENDOR = ~s~%" (glGetString GL_VENDOR))
|
||||||
|
(format #t "GL_EXTENSIONS = ~s~%" (glGetString GL_EXTENSIONS))
|
||||||
|
(newline)))
|
||||||
|
;;*** OpenGL END ***
|
||||||
|
)
|
||||||
|
|
||||||
|
(define idle
|
||||||
|
(let ((t0 #f))
|
||||||
|
(lambda ()
|
||||||
|
(let ((dt #f)
|
||||||
|
(t (/ (glutGet GLUT_ELAPSED_TIME) 1000.0)))
|
||||||
|
(unless (number? t0)
|
||||||
|
(set! t0 t))
|
||||||
|
(set! dt (- t t0))
|
||||||
|
(set! t0 t)
|
||||||
|
(set! *angle* (+ *angle* (* 70.0 dt))) ; 70 degrees per second
|
||||||
|
(set! *angle* (mod *angle* 360.0)) ; prevents eventual overflow
|
||||||
|
(glutPostRedisplay)))))
|
||||||
|
|
||||||
|
;; change view angle, exit upon ESC
|
||||||
|
(define (key rk x y)
|
||||||
|
(let ((q (lambda () (glutPostRedisplay)))
|
||||||
|
(k (c-int->c-uchar rk)))
|
||||||
|
(cond
|
||||||
|
((= k (char->integer #\z))
|
||||||
|
(set! *view-rotz* (mod (+ *view-rotz* 5.0) 360.0)) (q))
|
||||||
|
((= k (char->integer #\Z))
|
||||||
|
(set! *view-rotz* (mod (- *view-rotz* 5.0) 360.0)) (q))
|
||||||
|
((= k (char->integer #\esc)) (exit)))))
|
||||||
|
|
||||||
|
;; change view angle
|
||||||
|
(define (special k x y)
|
||||||
|
(let ((q (lambda () (glutPostRedisplay))))
|
||||||
|
(cond
|
||||||
|
((= k GLUT_KEY_UP)
|
||||||
|
(set! *view-rotx* (mod (+ *view-rotx* 5.0) 360.0)) (q))
|
||||||
|
((= k GLUT_KEY_DOWN)
|
||||||
|
(set! *view-rotx* (mod (- *view-rotx* 5.0) 360.0)) (q))
|
||||||
|
((= k GLUT_KEY_LEFT)
|
||||||
|
(set! *view-roty* (mod (+ *view-roty* 5.0) 360.0)) (q))
|
||||||
|
((= k GLUT_KEY_RIGHT)
|
||||||
|
(set! *view-roty* (mod (- *view-roty* 5.0) 360.0)) (q)))))
|
||||||
|
|
||||||
|
(define (visible vis)
|
||||||
|
(if (= vis GLUT_VISIBLE)
|
||||||
|
(glutIdleFunc idle)
|
||||||
|
(glutIdleFunc (lambda () (usleep 100000)))))
|
||||||
|
|
||||||
|
(begin
|
||||||
|
(glutInit (vector (length (command-line))) (apply vector (command-line)))
|
||||||
|
(glutInitDisplayMode (bitwise-ior GLUT_DOUBLE GLUT_DEPTH GLUT_RGB))
|
||||||
|
|
||||||
|
(glutInitWindowPosition 0 0)
|
||||||
|
(glutInitWindowSize 300 300)
|
||||||
|
|
||||||
|
(set! *win* (glutCreateWindow "Gears"))
|
||||||
|
(init)
|
||||||
|
|
||||||
|
(glutDisplayFunc draw)
|
||||||
|
(glutReshapeFunc reshape)
|
||||||
|
(glutKeyboardFunc key)
|
||||||
|
(glutSpecialFunc special)
|
||||||
|
(glutVisibilityFunc visible)
|
||||||
|
|
||||||
|
(glutMainLoop)
|
||||||
|
)
|
||||||
|
|
||||||
|
;; end
|
||||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,192 @@
|
||||||
|
#!/usr/bin/env ypsilon
|
||||||
|
|
||||||
|
;; glut-demo.scm:
|
||||||
|
;; GLUT, OpenGL, FFI, and Concurrent GC Stress Test
|
||||||
|
;;
|
||||||
|
;; Requirements:
|
||||||
|
;; Darwin: OpenGL.framework GLUT.framework
|
||||||
|
;; Windows: opengl32.dll glut32.dll
|
||||||
|
;; Linux: libGL.so.1 libglut.so.3
|
||||||
|
|
||||||
|
|
||||||
|
(import (core) (gl) (glut)
|
||||||
|
(rename (except (rnrs) angle display)
|
||||||
|
(reverse rnrs:reverse))
|
||||||
|
(rnrs programs))
|
||||||
|
(begin
|
||||||
|
|
||||||
|
|
||||||
|
(define object glutSolidIcosahedron)
|
||||||
|
(define reverse #t)
|
||||||
|
(define angle 0.0)
|
||||||
|
(define last-update 0)
|
||||||
|
|
||||||
|
(define display
|
||||||
|
(lambda ()
|
||||||
|
(glClear (+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT))
|
||||||
|
(do ((y 2.0 (+ y 3.0)))
|
||||||
|
((> y 14.0))
|
||||||
|
(do ((x 2.0 (+ x 3.0)))
|
||||||
|
((> x 14.0))
|
||||||
|
(if reverse
|
||||||
|
(render-one x y
|
||||||
|
0.4 (/ x 40.0) (/ y 40.0)
|
||||||
|
(/ x 20.0) (/ y 20.0) 0.4
|
||||||
|
(/ x 20.0) 0.2 (/ y 20.0)
|
||||||
|
(/ (+ x y) 20.0 100.0))
|
||||||
|
(render-one x y
|
||||||
|
(/ y 40.0) (/ x 40.0) 0.4
|
||||||
|
(/ x 20.0) 0.4 (/ y 20.0)
|
||||||
|
0.2 (/ x 20.0) (/ y 20.0)
|
||||||
|
(/ (+ x y) 20.0 100.0)))))
|
||||||
|
(glutSwapBuffers)))
|
||||||
|
|
||||||
|
(define rotate
|
||||||
|
(lambda ()
|
||||||
|
(cond ((< (+ last-update 16000) (microsecond))
|
||||||
|
(if (= (glutGetWindow) 0) (exit 0))
|
||||||
|
(if reverse
|
||||||
|
(let ((new-angle (+ angle 2.0)))
|
||||||
|
(if (>= new-angle 360.0)
|
||||||
|
(set! angle (- new-angle 360.0))
|
||||||
|
(set! angle new-angle)))
|
||||||
|
(let ((new-angle (- angle 2.0)))
|
||||||
|
(if (< new-angle 360.0)
|
||||||
|
(set! angle (+ new-angle 360.0))
|
||||||
|
(set! angle new-angle))))
|
||||||
|
(set! last-update (microsecond))
|
||||||
|
(glutPostRedisplay)))))
|
||||||
|
|
||||||
|
(define mouse
|
||||||
|
(lambda (button state x y)
|
||||||
|
(and (= state 0) (set! reverse (not reverse)))
|
||||||
|
(format #t "mouse callback ~s ~s ~s ~s ~%" button state x y)))
|
||||||
|
|
||||||
|
(define show-dodecahedron (lambda () (glScalef 0.6 0.6 0.6) (glutSolidDodecahedron)))
|
||||||
|
(define show-sphere (lambda () (glutSolidSphere 1.0 32 16)))
|
||||||
|
(define show-cone (lambda () (glutSolidCone 1.0 2.0 32 1)))
|
||||||
|
(define show-cube (lambda () (glutSolidCube 1.5)))
|
||||||
|
(define show-torus (lambda () (glutSolidTorus 0.5 1.0 16 32)))
|
||||||
|
|
||||||
|
(define menu
|
||||||
|
(lambda (m)
|
||||||
|
(format #t "menu callback ~s ~%" m)
|
||||||
|
(case m
|
||||||
|
((1) (set! object glutSolidIcosahedron))
|
||||||
|
((2) (set! object glutSolidOctahedron))
|
||||||
|
((3) (set! object glutSolidTetrahedron))
|
||||||
|
((4) (set! object show-dodecahedron))
|
||||||
|
((5) (set! object show-sphere))
|
||||||
|
((6) (set! object show-cone))
|
||||||
|
((7) (set! object show-cube))
|
||||||
|
((8) (set! object show-torus))
|
||||||
|
((9) (glShadeModel GL_SMOOTH))
|
||||||
|
((10) (glShadeModel GL_FLAT))
|
||||||
|
((11) (exit)))))
|
||||||
|
|
||||||
|
(define reshape
|
||||||
|
(lambda (w h)
|
||||||
|
(format #t "reshape callback ~s ~s ~%" w h)
|
||||||
|
(and (> w 0)
|
||||||
|
(> h 0)
|
||||||
|
(begin
|
||||||
|
(glViewport 0 0 w h)
|
||||||
|
(glMatrixMode GL_PROJECTION)
|
||||||
|
(glLoadIdentity)
|
||||||
|
(if (<= w h)
|
||||||
|
(glOrtho 0.0 16.0 0.0 (/ (* 16.0 h) w) -10.0 10.0)
|
||||||
|
(glOrtho 0.0 (/ (* 16.0 w) h) 0.0 16.0 -10.0 10.0))
|
||||||
|
(glMatrixMode GL_MODELVIEW)))))
|
||||||
|
|
||||||
|
(define visibility
|
||||||
|
(lambda (state)
|
||||||
|
(format #t "visibility callback ~s ~%" state)))
|
||||||
|
|
||||||
|
(define (f32vector . lst)
|
||||||
|
(define-syntax f32set!
|
||||||
|
(syntax-rules ()
|
||||||
|
((_ bv n value)
|
||||||
|
(bytevector-ieee-single-native-set! bv (* n 4) value))))
|
||||||
|
(let ((bv (make-bytevector (* (length lst) 4))))
|
||||||
|
(let loop ((i 0) (lst lst))
|
||||||
|
(cond ((null? lst)
|
||||||
|
(u8-list->bytevector (rnrs:reverse (bytevector->u8-list bv))))
|
||||||
|
(else
|
||||||
|
(f32set! bv i (car lst))
|
||||||
|
(loop (+ i 1) (cdr lst)))))))
|
||||||
|
|
||||||
|
#;
|
||||||
|
(define f32vector
|
||||||
|
(lambda lst
|
||||||
|
(define-syntax f32set!
|
||||||
|
(syntax-rules ()
|
||||||
|
((_ bv n value)
|
||||||
|
(bytevector-ieee-single-native-set! bv (* n 4) value))))
|
||||||
|
(let ((bv (make-bytevector (* (length lst) 4))))
|
||||||
|
(let loop ((i 0) (lst lst))
|
||||||
|
(cond ((null? lst) bv)
|
||||||
|
(else
|
||||||
|
(f32set! bv i (car lst))
|
||||||
|
(loop (+ i 1) (cdr lst))))))))
|
||||||
|
|
||||||
|
(define render-one
|
||||||
|
(lambda (x y ambr ambg ambb difr difg difb specr specg specb shine)
|
||||||
|
(glPushMatrix)
|
||||||
|
(glTranslatef x y 0.0)
|
||||||
|
(cond ((eq? object show-sphere)
|
||||||
|
(glRotatef 90.0 0.0 1.0 0.0)
|
||||||
|
(glRotatef angle 0.0 0.0 1.0))
|
||||||
|
(else
|
||||||
|
(glRotatef angle -0.3 1.0 -0.5)))
|
||||||
|
(glMaterialfv GL_FRONT GL_AMBIENT (f32vector ambr ambg ambb 1.0))
|
||||||
|
(glMaterialfv GL_FRONT GL_DIFFUSE (f32vector difr difg difb 1.0))
|
||||||
|
(glMaterialfv GL_FRONT GL_SPECULAR (f32vector specr specg specb 1.0))
|
||||||
|
(glMaterialf GL_FRONT GL_SHININESS (* shine 128.0))
|
||||||
|
(object)
|
||||||
|
(glPopMatrix)))
|
||||||
|
|
||||||
|
#;(import (trace))
|
||||||
|
#;(trace render-one)
|
||||||
|
#;(collect-notify #t)
|
||||||
|
|
||||||
|
(define run
|
||||||
|
(lambda ()
|
||||||
|
(glutInitDisplayMode (+ GLUT_DOUBLE GLUT_RGBA GLUT_DEPTH))
|
||||||
|
(glutInitWindowPosition 100 100)
|
||||||
|
(glutInitWindowSize 500 500)
|
||||||
|
(glutInit (vector (length (command-line))) (apply vector (command-line)))
|
||||||
|
(glutCreateWindow "Hello GLUT")
|
||||||
|
(glLightfv GL_LIGHT0 GL_AMBIENT (f32vector 0.0 0.0 0.0 1.0))
|
||||||
|
(glLightfv GL_LIGHT0 GL_DIFFUSE (f32vector 1.0 1.0 1.0 1.0))
|
||||||
|
(glLightfv GL_LIGHT0 GL_POSITION (f32vector 0.0 3.0 3.0 0.0))
|
||||||
|
(glLightModelfv GL_LIGHT_MODEL_AMBIENT (f32vector 0.2 0.2 0.2 1.0))
|
||||||
|
(glLightModelfv GL_LIGHT_MODEL_LOCAL_VIEWER (f32vector 0.0))
|
||||||
|
(glShadeModel GL_FLAT)
|
||||||
|
(glFrontFace GL_CW)
|
||||||
|
(glEnable GL_LIGHTING)
|
||||||
|
(glEnable GL_LIGHT0)
|
||||||
|
(glEnable GL_AUTO_NORMAL)
|
||||||
|
(glEnable GL_NORMALIZE)
|
||||||
|
(glEnable GL_DEPTH_TEST)
|
||||||
|
(glDepthFunc GL_LESS)
|
||||||
|
(glutDisplayFunc display)
|
||||||
|
(glutReshapeFunc reshape)
|
||||||
|
(glutVisibilityFunc visibility)
|
||||||
|
(glutMouseFunc mouse)
|
||||||
|
(glutIdleFunc rotate)
|
||||||
|
(glutCreateMenu menu)
|
||||||
|
(glutAddMenuEntry "Icosahedron" 1)
|
||||||
|
(glutAddMenuEntry "Octahedron" 2)
|
||||||
|
(glutAddMenuEntry "Tetrahedron" 3)
|
||||||
|
(glutAddMenuEntry "Dodecahedron" 4)
|
||||||
|
(glutAddMenuEntry "Sphere" 5)
|
||||||
|
(glutAddMenuEntry "Cone" 6)
|
||||||
|
(glutAddMenuEntry "Cube" 7)
|
||||||
|
(glutAddMenuEntry "Torus" 8)
|
||||||
|
(glutAddMenuEntry "[smooth]" 9)
|
||||||
|
(glutAddMenuEntry "[flat]" 10)
|
||||||
|
(glutAddMenuEntry "Exit" 11)
|
||||||
|
(glutAttachMenu GLUT_RIGHT_BUTTON)
|
||||||
|
(glutMainLoop)))
|
||||||
|
|
||||||
|
(run))
|
||||||
|
|
@ -0,0 +1,620 @@
|
||||||
|
;;; Ypsilon Scheme System
|
||||||
|
;;; Copyright (c) 2004-2008 Y.FUJITA, LittleWing Company Limited.
|
||||||
|
;;; See license.txt for terms and conditions of use.
|
||||||
|
|
||||||
|
(library (glut)
|
||||||
|
|
||||||
|
(export GLUT_RGB
|
||||||
|
GLUT_RGBA
|
||||||
|
GLUT_INDEX
|
||||||
|
GLUT_SINGLE
|
||||||
|
GLUT_DOUBLE
|
||||||
|
GLUT_ACCUM
|
||||||
|
GLUT_ALPHA
|
||||||
|
GLUT_DEPTH
|
||||||
|
GLUT_STENCIL
|
||||||
|
GLUT_MULTISAMPLE
|
||||||
|
GLUT_STEREO
|
||||||
|
GLUT_LUMINANCE
|
||||||
|
GLUT_NO_RECOVERY
|
||||||
|
GLUT_LEFT_BUTTON
|
||||||
|
GLUT_MIDDLE_BUTTON
|
||||||
|
GLUT_RIGHT_BUTTON
|
||||||
|
GLUT_DOWN
|
||||||
|
GLUT_UP
|
||||||
|
GLUT_KEY_F1
|
||||||
|
GLUT_KEY_F2
|
||||||
|
GLUT_KEY_F3
|
||||||
|
GLUT_KEY_F4
|
||||||
|
GLUT_KEY_F5
|
||||||
|
GLUT_KEY_F6
|
||||||
|
GLUT_KEY_F7
|
||||||
|
GLUT_KEY_F8
|
||||||
|
GLUT_KEY_F9
|
||||||
|
GLUT_KEY_F10
|
||||||
|
GLUT_KEY_F11
|
||||||
|
GLUT_KEY_F12
|
||||||
|
GLUT_KEY_LEFT
|
||||||
|
GLUT_KEY_UP
|
||||||
|
GLUT_KEY_RIGHT
|
||||||
|
GLUT_KEY_DOWN
|
||||||
|
GLUT_KEY_PAGE_UP
|
||||||
|
GLUT_KEY_PAGE_DOWN
|
||||||
|
GLUT_KEY_HOME
|
||||||
|
GLUT_KEY_END
|
||||||
|
GLUT_KEY_INSERT
|
||||||
|
GLUT_LEFT
|
||||||
|
GLUT_ENTERED
|
||||||
|
GLUT_MENU_NOT_IN_USE
|
||||||
|
GLUT_MENU_IN_USE
|
||||||
|
GLUT_NOT_VISIBLE
|
||||||
|
GLUT_VISIBLE
|
||||||
|
GLUT_HIDDEN
|
||||||
|
GLUT_FULLY_RETAINED
|
||||||
|
GLUT_PARTIALLY_RETAINED
|
||||||
|
GLUT_FULLY_COVERED
|
||||||
|
GLUT_RED
|
||||||
|
GLUT_GREEN
|
||||||
|
GLUT_BLUE
|
||||||
|
GLUT_NORMAL
|
||||||
|
GLUT_OVERLAY
|
||||||
|
|
||||||
|
glutInit
|
||||||
|
glutInitDisplayString
|
||||||
|
glutInitDisplayMode
|
||||||
|
glutInitWindowPosition
|
||||||
|
glutInitWindowSize
|
||||||
|
glutMainLoop
|
||||||
|
glutCreateWindow
|
||||||
|
glutCreateSubWindow
|
||||||
|
glutDestroyWindow
|
||||||
|
glutPostRedisplay
|
||||||
|
glutPostWindowRedisplay
|
||||||
|
glutSwapBuffers
|
||||||
|
glutGetWindow
|
||||||
|
glutSetWindow
|
||||||
|
glutSetWindowTitle
|
||||||
|
glutSetIconTitle
|
||||||
|
glutPositionWindow
|
||||||
|
glutReshapeWindow
|
||||||
|
glutPopWindow
|
||||||
|
glutPushWindow
|
||||||
|
glutIconifyWindow
|
||||||
|
glutShowWindow
|
||||||
|
glutHideWindow
|
||||||
|
glutFullScreen
|
||||||
|
glutSetCursor
|
||||||
|
glutWarpPointer
|
||||||
|
glutEstablishOverlay
|
||||||
|
glutRemoveOverlay
|
||||||
|
glutUseLayer
|
||||||
|
glutPostOverlayRedisplay
|
||||||
|
glutPostWindowOverlayRedisplay
|
||||||
|
glutShowOverlay
|
||||||
|
glutHideOverlay
|
||||||
|
glutCreateMenu
|
||||||
|
glutDestroyMenu
|
||||||
|
glutGetMenu
|
||||||
|
glutSetMenu
|
||||||
|
glutAddMenuEntry
|
||||||
|
glutAddSubMenu
|
||||||
|
glutChangeToMenuEntry
|
||||||
|
glutChangeToSubMenu
|
||||||
|
glutRemoveMenuItem
|
||||||
|
glutAttachMenu
|
||||||
|
glutDetachMenu
|
||||||
|
glutDisplayFunc
|
||||||
|
glutReshapeFunc
|
||||||
|
glutKeyboardFunc
|
||||||
|
glutMouseFunc
|
||||||
|
glutMotionFunc
|
||||||
|
glutPassiveMotionFunc
|
||||||
|
glutEntryFunc
|
||||||
|
glutVisibilityFunc
|
||||||
|
glutIdleFunc
|
||||||
|
glutTimerFunc
|
||||||
|
glutMenuStateFunc
|
||||||
|
glutSpecialFunc
|
||||||
|
glutSpaceballMotionFunc
|
||||||
|
glutSpaceballRotateFunc
|
||||||
|
glutSpaceballButtonFunc
|
||||||
|
glutButtonBoxFunc
|
||||||
|
glutDialsFunc
|
||||||
|
glutTabletMotionFunc
|
||||||
|
glutTabletButtonFunc
|
||||||
|
glutMenuStatusFunc
|
||||||
|
glutOverlayDisplayFunc
|
||||||
|
glutWindowStatusFunc
|
||||||
|
glutKeyboardUpFunc
|
||||||
|
glutSpecialUpFunc
|
||||||
|
glutJoystickFunc
|
||||||
|
glutSetColor
|
||||||
|
glutGetColor
|
||||||
|
glutCopyColormap
|
||||||
|
glutGet
|
||||||
|
glutDeviceGet
|
||||||
|
glutExtensionSupported
|
||||||
|
glutGetModifiers
|
||||||
|
glutLayerGet
|
||||||
|
glutGetProcAddress
|
||||||
|
glutBitmapCharacter
|
||||||
|
glutBitmapWidth
|
||||||
|
glutStrokeCharacter
|
||||||
|
glutStrokeWidth
|
||||||
|
glutBitmapLength
|
||||||
|
glutStrokeLength
|
||||||
|
glutWireSphere
|
||||||
|
glutSolidSphere
|
||||||
|
glutWireCone
|
||||||
|
glutSolidCone
|
||||||
|
glutWireCube
|
||||||
|
glutSolidCube
|
||||||
|
glutWireTorus
|
||||||
|
glutSolidTorus
|
||||||
|
glutWireDodecahedron
|
||||||
|
glutSolidDodecahedron
|
||||||
|
glutWireTeapot
|
||||||
|
glutSolidTeapot
|
||||||
|
glutWireOctahedron
|
||||||
|
glutSolidOctahedron
|
||||||
|
glutWireTetrahedron
|
||||||
|
glutSolidTetrahedron
|
||||||
|
glutWireIcosahedron
|
||||||
|
glutSolidIcosahedron
|
||||||
|
glutVideoResizeGet
|
||||||
|
glutSetupVideoResizing
|
||||||
|
glutStopVideoResizing
|
||||||
|
glutVideoResize
|
||||||
|
glutVideoPan
|
||||||
|
glutReportErrors
|
||||||
|
glutIgnoreKeyRepeat
|
||||||
|
glutSetKeyRepeat
|
||||||
|
glutForceJoystickFunc
|
||||||
|
glutGameModeString
|
||||||
|
glutEnterGameMode
|
||||||
|
glutLeaveGameMode
|
||||||
|
glutGameModeGet)
|
||||||
|
|
||||||
|
(import (rnrs) (core) (ffi))
|
||||||
|
|
||||||
|
(define libGLUT (cond (on-darwin (load-shared-object "GLUT.framework/GLUT"))
|
||||||
|
(on-windows (load-shared-object "glut32.dll"))
|
||||||
|
(on-linux (load-shared-object "libglut.so.3"))
|
||||||
|
(on-freebsd (load-shared-object "libglut.so.4"))
|
||||||
|
(else (assertion-violation #f "can not locate GLUT library, unknown operating system"))))
|
||||||
|
|
||||||
|
;; Display mode bit masks.
|
||||||
|
(define GLUT_RGB 0)
|
||||||
|
(define GLUT_RGBA GLUT_RGB)
|
||||||
|
(define GLUT_INDEX 1)
|
||||||
|
(define GLUT_SINGLE 0)
|
||||||
|
(define GLUT_DOUBLE 2)
|
||||||
|
(define GLUT_ACCUM 4)
|
||||||
|
(define GLUT_ALPHA 8)
|
||||||
|
(define GLUT_DEPTH 16)
|
||||||
|
(define GLUT_STENCIL 32)
|
||||||
|
(define GLUT_MULTISAMPLE 128)
|
||||||
|
(define GLUT_STEREO 256)
|
||||||
|
(define GLUT_LUMINANCE 512)
|
||||||
|
(define GLUT_NO_RECOVERY 1024)
|
||||||
|
|
||||||
|
;; Mouse buttons.
|
||||||
|
(define GLUT_LEFT_BUTTON 0)
|
||||||
|
(define GLUT_MIDDLE_BUTTON 1)
|
||||||
|
(define GLUT_RIGHT_BUTTON 2)
|
||||||
|
|
||||||
|
;; Mouse button state.
|
||||||
|
(define GLUT_DOWN 0)
|
||||||
|
(define GLUT_UP 1)
|
||||||
|
|
||||||
|
;; function keys
|
||||||
|
(define GLUT_KEY_F1 1)
|
||||||
|
(define GLUT_KEY_F2 2)
|
||||||
|
(define GLUT_KEY_F3 3)
|
||||||
|
(define GLUT_KEY_F4 4)
|
||||||
|
(define GLUT_KEY_F5 5)
|
||||||
|
(define GLUT_KEY_F6 6)
|
||||||
|
(define GLUT_KEY_F7 7)
|
||||||
|
(define GLUT_KEY_F8 8)
|
||||||
|
(define GLUT_KEY_F9 9)
|
||||||
|
(define GLUT_KEY_F10 10)
|
||||||
|
(define GLUT_KEY_F11 11)
|
||||||
|
(define GLUT_KEY_F12 12)
|
||||||
|
|
||||||
|
;; directional keys
|
||||||
|
(define GLUT_KEY_LEFT 100)
|
||||||
|
(define GLUT_KEY_UP 101)
|
||||||
|
(define GLUT_KEY_RIGHT 102)
|
||||||
|
(define GLUT_KEY_DOWN 103)
|
||||||
|
(define GLUT_KEY_PAGE_UP 104)
|
||||||
|
(define GLUT_KEY_PAGE_DOWN 105)
|
||||||
|
(define GLUT_KEY_HOME 106)
|
||||||
|
(define GLUT_KEY_END 107)
|
||||||
|
(define GLUT_KEY_INSERT 108)
|
||||||
|
|
||||||
|
;; Entry/exit state.
|
||||||
|
(define GLUT_LEFT 0)
|
||||||
|
(define GLUT_ENTERED 1)
|
||||||
|
|
||||||
|
;; Menu usage state.
|
||||||
|
(define GLUT_MENU_NOT_IN_USE 0)
|
||||||
|
(define GLUT_MENU_IN_USE 1)
|
||||||
|
|
||||||
|
;; Visibility state.
|
||||||
|
(define GLUT_NOT_VISIBLE 0)
|
||||||
|
(define GLUT_VISIBLE 1)
|
||||||
|
|
||||||
|
;; Window status state.
|
||||||
|
(define GLUT_HIDDEN 0)
|
||||||
|
(define GLUT_FULLY_RETAINED 1)
|
||||||
|
(define GLUT_PARTIALLY_RETAINED 2)
|
||||||
|
(define GLUT_FULLY_COVERED 3)
|
||||||
|
|
||||||
|
;; Color index component selection values.
|
||||||
|
(define GLUT_RED 0)
|
||||||
|
(define GLUT_GREEN 1)
|
||||||
|
(define GLUT_BLUE 2)
|
||||||
|
|
||||||
|
;; Layers for use.
|
||||||
|
(define GLUT_NORMAL 0)
|
||||||
|
(define GLUT_OVERLAY 1)
|
||||||
|
|
||||||
|
(define-syntax define-function
|
||||||
|
(syntax-rules ()
|
||||||
|
((_ ret name args)
|
||||||
|
(define name (c-function libGLUT "GLUT library" ret __stdcall name args)))))
|
||||||
|
|
||||||
|
;; void glutInit(int *argcp, char **argv)
|
||||||
|
;; (define-function void glutInit ([int] [char*]))
|
||||||
|
(define glutInit
|
||||||
|
(if on-windows
|
||||||
|
(lambda (a1 a2)
|
||||||
|
(c-argument 'glutInit 1 [int] a1)
|
||||||
|
(c-argument 'glutInit 2 [char*] a2)
|
||||||
|
((c-function libGLUT "GLUT library" void __stdcall __glutInitWithExit ([int] [char*] [c-callback void (int)]))
|
||||||
|
a1 a2 (lambda (n) (exit n))))
|
||||||
|
(c-function libGLUT "GLUT library" void __stdcall glutInit ([int] [char*]))))
|
||||||
|
|
||||||
|
;; void glutInitDisplayString(const char *string)
|
||||||
|
(define-function void glutInitDisplayString (char*))
|
||||||
|
|
||||||
|
;; void glutInitDisplayMode(unsigned int mode)
|
||||||
|
(define-function void glutInitDisplayMode (int))
|
||||||
|
|
||||||
|
;; void glutInitWindowPosition(int x, int y)
|
||||||
|
(define-function void glutInitWindowPosition (int int))
|
||||||
|
|
||||||
|
;; void glutInitWindowSize(int width, int height)
|
||||||
|
(define-function void glutInitWindowSize (int int))
|
||||||
|
|
||||||
|
;; void glutMainLoop(void)
|
||||||
|
(define-function void glutMainLoop ())
|
||||||
|
|
||||||
|
;; int glutCreateWindow(const char *title)
|
||||||
|
(define-function int glutCreateWindow (char*))
|
||||||
|
|
||||||
|
;; int glutCreateSubWindow(int win, int x, int y, int width, int height)
|
||||||
|
(define-function int glutCreateSubWindow (int int int int int))
|
||||||
|
|
||||||
|
;; void glutDestroyWindow(int win)
|
||||||
|
(define-function void glutDestroyWindow (int))
|
||||||
|
|
||||||
|
;; void glutPostRedisplay(void)
|
||||||
|
(define-function void glutPostRedisplay ())
|
||||||
|
|
||||||
|
;; void glutPostWindowRedisplay(int win)
|
||||||
|
(define-function void glutPostWindowRedisplay (int))
|
||||||
|
|
||||||
|
;; void glutSwapBuffers(void)
|
||||||
|
(define-function void glutSwapBuffers ())
|
||||||
|
|
||||||
|
;; int glutGetWindow(void)
|
||||||
|
(define-function int glutGetWindow ())
|
||||||
|
|
||||||
|
;; void glutSetWindow(int win)
|
||||||
|
(define-function void glutSetWindow (int))
|
||||||
|
|
||||||
|
;; void glutSetWindowTitle(const char *title)
|
||||||
|
(define-function void glutSetWindowTitle (char*))
|
||||||
|
|
||||||
|
;; void glutSetIconTitle(const char *title)
|
||||||
|
(define-function void glutSetIconTitle (char*))
|
||||||
|
|
||||||
|
;; void glutPositionWindow(int x, int y)
|
||||||
|
(define-function void glutPositionWindow (int int))
|
||||||
|
|
||||||
|
;; void glutReshapeWindow(int width, int height)
|
||||||
|
(define-function void glutReshapeWindow (int int))
|
||||||
|
|
||||||
|
;; void glutPopWindow(void)
|
||||||
|
(define-function void glutPopWindow ())
|
||||||
|
|
||||||
|
;; void glutPushWindow(void)
|
||||||
|
(define-function void glutPushWindow ())
|
||||||
|
|
||||||
|
;; void glutIconifyWindow(void)
|
||||||
|
(define-function void glutIconifyWindow ())
|
||||||
|
|
||||||
|
;; void glutShowWindow(void)
|
||||||
|
(define-function void glutShowWindow ())
|
||||||
|
|
||||||
|
;; void glutHideWindow(void)
|
||||||
|
(define-function void glutHideWindow ())
|
||||||
|
|
||||||
|
;; void glutFullScreen(void)
|
||||||
|
(define-function void glutFullScreen ())
|
||||||
|
|
||||||
|
;; void glutSetCursor(int cursor)
|
||||||
|
(define-function void glutSetCursor (int))
|
||||||
|
|
||||||
|
;; void glutWarpPointer(int x, int y)
|
||||||
|
(define-function void glutWarpPointer (int int))
|
||||||
|
|
||||||
|
;; void glutEstablishOverlay(void)
|
||||||
|
(define-function void glutEstablishOverlay ())
|
||||||
|
|
||||||
|
;; void glutRemoveOverlay(void)
|
||||||
|
(define-function void glutRemoveOverlay ())
|
||||||
|
|
||||||
|
;; void glutUseLayer(GLenum layer)
|
||||||
|
(define-function void glutUseLayer (int))
|
||||||
|
|
||||||
|
;; void glutPostOverlayRedisplay(void)
|
||||||
|
(define-function void glutPostOverlayRedisplay ())
|
||||||
|
|
||||||
|
;; void glutPostWindowOverlayRedisplay(int win)
|
||||||
|
(define-function void glutPostWindowOverlayRedisplay (int))
|
||||||
|
|
||||||
|
;; void glutShowOverlay(void)
|
||||||
|
(define-function void glutShowOverlay ())
|
||||||
|
|
||||||
|
;; void glutHideOverlay(void)
|
||||||
|
(define-function void glutHideOverlay ())
|
||||||
|
|
||||||
|
;; int glutCreateMenu(void (*)(int))
|
||||||
|
(define-function void glutCreateMenu ([c-callback void (int)]))
|
||||||
|
|
||||||
|
;; void glutDestroyMenu(int menu)
|
||||||
|
(define-function void glutDestroyMenu (int))
|
||||||
|
|
||||||
|
;; int glutGetMenu(void)
|
||||||
|
(define-function int glutGetMenu ())
|
||||||
|
|
||||||
|
;; void glutSetMenu(int menu)
|
||||||
|
(define-function void glutSetMenu (int))
|
||||||
|
|
||||||
|
;; void glutAddMenuEntry(const char *label, int value)
|
||||||
|
(define-function void glutAddMenuEntry (char* int))
|
||||||
|
|
||||||
|
;; void glutAddSubMenu(const char *label, int submenu)
|
||||||
|
(define-function void glutAddSubMenu (char* int))
|
||||||
|
|
||||||
|
;; void glutChangeToMenuEntry(int item, const char *label, int value)
|
||||||
|
(define-function void glutChangeToMenuEntry (int char* int))
|
||||||
|
|
||||||
|
;; void glutChangeToSubMenu(int item, const char *label, int submenu)
|
||||||
|
(define-function void glutChangeToSubMenu (int char* int))
|
||||||
|
|
||||||
|
;; void glutRemoveMenuItem(int item)
|
||||||
|
(define-function void glutRemoveMenuItem (int))
|
||||||
|
|
||||||
|
;; void glutAttachMenu(int button)
|
||||||
|
(define-function void glutAttachMenu (int))
|
||||||
|
|
||||||
|
;; void glutDetachMenu(int button)
|
||||||
|
(define-function void glutDetachMenu (int))
|
||||||
|
|
||||||
|
;; void glutDisplayFunc(void (*func)(void))
|
||||||
|
(define-function void glutDisplayFunc ([c-callback void ()]))
|
||||||
|
|
||||||
|
;; void glutReshapeFunc(void (*func)(int width, int height))
|
||||||
|
(define-function void glutReshapeFunc ([c-callback void (int int)]))
|
||||||
|
|
||||||
|
;; void glutKeyboardFunc(void (*func)(unsigned char key, int x, int y))
|
||||||
|
(define-function void glutKeyboardFunc ([c-callback void (int int int)]))
|
||||||
|
|
||||||
|
;; void glutMouseFunc(void (*func)(int button, int state, int x, int y))
|
||||||
|
(define-function void glutMouseFunc ([c-callback void (int int int int)]))
|
||||||
|
|
||||||
|
;; void glutMotionFunc(void (*func)(int x, int y))
|
||||||
|
(define-function void glutMotionFunc ([c-callback void (int int)]))
|
||||||
|
|
||||||
|
;; void glutPassiveMotionFunc(void (*func)(int x, int y))
|
||||||
|
(define-function void glutPassiveMotionFunc ([c-callback void (int int)]))
|
||||||
|
|
||||||
|
;; void glutEntryFunc(void (*func)(int state))
|
||||||
|
(define-function void glutEntryFunc ([c-callback void (int)]))
|
||||||
|
|
||||||
|
;; void glutVisibilityFunc(void (*func)(int state))
|
||||||
|
(define-function void glutVisibilityFunc ([c-callback void (int)]))
|
||||||
|
|
||||||
|
;; void glutIdleFunc(void (*func)(void))
|
||||||
|
(define-function void glutIdleFunc ([c-callback void ()]))
|
||||||
|
|
||||||
|
;; void glutTimerFunc(unsigned int millis, void (*func)(int value), int value)
|
||||||
|
(define-function void glutTimerFunc (int [c-callback void (int)] int))
|
||||||
|
|
||||||
|
;; void glutMenuStateFunc(void (*func)(int state))
|
||||||
|
(define-function void glutMenuStateFunc ([c-callback void (int)]))
|
||||||
|
|
||||||
|
;; void glutSpecialFunc(void (*func)(int key, int x, int y))
|
||||||
|
(define-function void glutSpecialFunc ([c-callback void (int int int)]))
|
||||||
|
|
||||||
|
;; void glutSpaceballMotionFunc(void (*func)(int x, int y, int z))
|
||||||
|
(define-function void glutSpaceballMotionFunc ([c-callback void (int int int)]))
|
||||||
|
|
||||||
|
;; void glutSpaceballRotateFunc(void (*func)(int x, int y, int z))
|
||||||
|
(define-function void glutSpaceballRotateFunc ([c-callback void (int int int)]))
|
||||||
|
|
||||||
|
;; void glutSpaceballButtonFunc(void (*func)(int button, int state))
|
||||||
|
(define-function void glutSpaceballButtonFunc ([c-callback void (int int)]))
|
||||||
|
|
||||||
|
;; void glutButtonBoxFunc(void (*func)(int button, int state))
|
||||||
|
(define-function void glutButtonBoxFunc ([c-callback void (int int)]))
|
||||||
|
|
||||||
|
;; void glutDialsFunc(void (*func)(int dial, int value))
|
||||||
|
(define-function void glutDialsFunc ([c-callback void (int int)]))
|
||||||
|
|
||||||
|
;; void glutTabletMotionFunc(void (*func)(int x, int y))
|
||||||
|
(define-function void glutTabletMotionFunc ([c-callback void (int int)]))
|
||||||
|
|
||||||
|
;; void glutTabletButtonFunc(void (*func)(int button, int state, int x, int y))
|
||||||
|
(define-function void glutTabletButtonFunc ([c-callback void (int int int int)]))
|
||||||
|
|
||||||
|
;; void glutMenuStatusFunc(void (*func)(int status, int x, int y))
|
||||||
|
(define-function void glutMenuStatusFunc ([c-callback void (int int int)]))
|
||||||
|
|
||||||
|
;; void glutOverlayDisplayFunc(void (*func)(void))
|
||||||
|
(define-function void glutOverlayDisplayFunc ([c-callback void ()]))
|
||||||
|
|
||||||
|
;; void glutWindowStatusFunc(void (*func)(int state))
|
||||||
|
(define-function void glutWindowStatusFunc ([c-callback void (int)]))
|
||||||
|
|
||||||
|
;; void glutKeyboardUpFunc(void (*func)(unsigned char key, int x, int y))
|
||||||
|
(define-function void glutKeyboardUpFunc ([c-callback void (int int int)]))
|
||||||
|
|
||||||
|
;; void glutSpecialUpFunc(void (*func)(int key, int x, int y))
|
||||||
|
(define-function void glutSpecialUpFunc ([c-callback void (int int int)]))
|
||||||
|
|
||||||
|
;; void glutJoystickFunc(void (*func)(unsigned int buttonMask, int x, int y, int z), int pollInterval)
|
||||||
|
(define-function void glutJoystickFunc ([c-callback void (int int int int)] int))
|
||||||
|
|
||||||
|
;; void glutSetColor(int, GLfloat red, GLfloat green, GLfloat blue)
|
||||||
|
(define-function void glutSetColor (int float float float))
|
||||||
|
|
||||||
|
;; GLfloat glutGetColor(int ndx, int component)
|
||||||
|
(define-function double glutGetColor (int int))
|
||||||
|
|
||||||
|
;; void glutCopyColormap(int win)
|
||||||
|
(define-function void glutCopyColormap (int))
|
||||||
|
|
||||||
|
;; int glutGet(GLenum type)
|
||||||
|
(define-function int glutGet (int))
|
||||||
|
|
||||||
|
;; int glutDeviceGet(GLenum type)
|
||||||
|
(define-function int glutDeviceGet (int))
|
||||||
|
|
||||||
|
;; int glutExtensionSupported(const char *name)
|
||||||
|
(define-function int glutExtensionSupported (char*))
|
||||||
|
|
||||||
|
;; int glutGetModifiers(void)
|
||||||
|
(define-function int glutGetModifiers ())
|
||||||
|
|
||||||
|
;; int glutLayerGet(GLenum type)
|
||||||
|
(define-function int glutLayerGet (int))
|
||||||
|
|
||||||
|
;; void * glutGetProcAddress(const char *procName)
|
||||||
|
(define-function void* glutGetProcAddress (char*))
|
||||||
|
|
||||||
|
;; void glutBitmapCharacter(void *font, int character)
|
||||||
|
(define-function void* glutBitmapCharacter (void* int))
|
||||||
|
|
||||||
|
;; int glutBitmapWidth(void *font, int character)
|
||||||
|
(define-function int glutBitmapWidth (void* int))
|
||||||
|
|
||||||
|
;; void glutStrokeCharacter(void *font, int character)
|
||||||
|
(define-function void glutStrokeCharacter (void* int))
|
||||||
|
|
||||||
|
;; int glutStrokeWidth(void *font, int character)
|
||||||
|
(define-function int glutStrokeWidth (void* int))
|
||||||
|
|
||||||
|
;; int glutBitmapLength(void *font, const unsigned char *string)
|
||||||
|
(define-function int glutBitmapLength (void* char*))
|
||||||
|
|
||||||
|
;; int glutStrokeLength(void *font, const unsigned char *string)
|
||||||
|
(define-function int glutStrokeLength (void* char*))
|
||||||
|
|
||||||
|
;; void glutWireSphere(GLdouble radius, GLint slices, GLint stacks)
|
||||||
|
(define-function int glutWireSphere (double int int))
|
||||||
|
|
||||||
|
;; void glutSolidSphere(GLdouble radius, GLint slices, GLint stacks)
|
||||||
|
(define-function void glutSolidSphere (double int int))
|
||||||
|
|
||||||
|
;; void glutWireCone(GLdouble base, GLdouble height, GLint slices, GLint stacks)
|
||||||
|
(define-function void glutWireCone (double double int int))
|
||||||
|
|
||||||
|
;; void glutSolidCone(GLdouble base, GLdouble height, GLint slices, GLint stacks)
|
||||||
|
(define-function void glutSolidCone (double double int int))
|
||||||
|
|
||||||
|
;; void glutWireCube(GLdouble size)
|
||||||
|
(define-function void glutWireCube (double))
|
||||||
|
|
||||||
|
;; void glutSolidCube(GLdouble size)
|
||||||
|
(define-function void glutSolidCube (double))
|
||||||
|
|
||||||
|
;; void glutWireTorus(GLdouble innerRadius, GLdouble outerRadius, GLint sides, GLint rings)
|
||||||
|
(define-function void glutWireTorus (double double int int))
|
||||||
|
|
||||||
|
;; void glutSolidTorus(GLdouble innerRadius, GLdouble outerRadius, GLint sides, GLint rings)
|
||||||
|
(define-function void glutSolidTorus (double double int int))
|
||||||
|
|
||||||
|
;; void glutWireDodecahedron(void)
|
||||||
|
(define-function void glutWireDodecahedron ())
|
||||||
|
|
||||||
|
;; void glutSolidDodecahedron(void)
|
||||||
|
(define-function void glutSolidDodecahedron ())
|
||||||
|
|
||||||
|
;; void glutWireTeapot(GLdouble size)
|
||||||
|
(define-function void glutWireTeapot (double))
|
||||||
|
|
||||||
|
;; void glutSolidTeapot(GLdouble size)
|
||||||
|
(define-function void glutSolidTeapot (double))
|
||||||
|
|
||||||
|
;; void glutWireOctahedron(void)
|
||||||
|
(define-function void glutWireOctahedron ())
|
||||||
|
|
||||||
|
;; void glutSolidOctahedron(void)
|
||||||
|
(define-function void glutSolidOctahedron ())
|
||||||
|
|
||||||
|
;; void glutWireTetrahedron(void)
|
||||||
|
(define-function void glutWireTetrahedron ())
|
||||||
|
|
||||||
|
;; void glutSolidTetrahedron(void)
|
||||||
|
(define-function void glutSolidTetrahedron ())
|
||||||
|
|
||||||
|
;; void glutWireIcosahedron(void)
|
||||||
|
(define-function void glutWireIcosahedron ())
|
||||||
|
|
||||||
|
;; void glutSolidIcosahedron(void)
|
||||||
|
(define-function void glutSolidIcosahedron ())
|
||||||
|
|
||||||
|
;; int glutVideoResizeGet(GLenum param)
|
||||||
|
(define-function int glutVideoResizeGet ())
|
||||||
|
|
||||||
|
;; void glutSetupVideoResizing(void)
|
||||||
|
(define-function int glutSetupVideoResizing ())
|
||||||
|
|
||||||
|
;; void glutStopVideoResizing(void)
|
||||||
|
(define-function void glutStopVideoResizing ())
|
||||||
|
|
||||||
|
;; void glutVideoResize(int x, int y, int width, int height)
|
||||||
|
(define-function void glutVideoResize (int int int int))
|
||||||
|
|
||||||
|
;; void glutVideoPan(int x, int y, int width, int height)
|
||||||
|
(define-function void glutVideoPan (int int int int))
|
||||||
|
|
||||||
|
;; void glutReportErrors(void)
|
||||||
|
(define-function void glutReportErrors ())
|
||||||
|
|
||||||
|
;; void glutIgnoreKeyRepeat(int ignore)
|
||||||
|
(define-function void glutIgnoreKeyRepeat (int))
|
||||||
|
|
||||||
|
;; void glutSetKeyRepeat(int repeatMode)
|
||||||
|
(define-function void glutSetKeyRepeat (int))
|
||||||
|
|
||||||
|
;; void glutForceJoystickFunc(void)
|
||||||
|
(define-function void glutForceJoystickFunc ())
|
||||||
|
|
||||||
|
;; void glutGameModeString(const char *string)
|
||||||
|
(define-function void glutGameModeString (char*))
|
||||||
|
|
||||||
|
;; int glutEnterGameMode(void)
|
||||||
|
(define-function int glutEnterGameMode ())
|
||||||
|
|
||||||
|
;; void glutLeaveGameMode(void)
|
||||||
|
(define-function void glutLeaveGameMode ())
|
||||||
|
|
||||||
|
;; int glutGameModeGet(GLenum mode)
|
||||||
|
(define-function int glutGameModeGet (int))
|
||||||
|
|
||||||
|
) ;[end]
|
||||||
|
|
@ -160,9 +160,7 @@
|
||||||
(unless (= (vector-length argsvec)
|
(unless (= (vector-length argsvec)
|
||||||
(vector-length argtypes-n))
|
(vector-length argtypes-n))
|
||||||
(error 'ffi "args mismatch" argtypes args))
|
(error 'ffi "args mismatch" argtypes args))
|
||||||
(call/cc
|
(foreign-call "ikrt_ffi_call" data argsvec))))))
|
||||||
(lambda (k)
|
|
||||||
(foreign-call "ikrt_ffi_call" data argsvec))))))))
|
|
||||||
|
|
||||||
(define (make-callback rtype argtypes)
|
(define (make-callback rtype argtypes)
|
||||||
(let-values ([(cif argtypes-n rtype-n)
|
(let-values ([(cif argtypes-n rtype-n)
|
||||||
|
|
|
||||||
|
|
@ -1 +1 @@
|
||||||
1605
|
1606
|
||||||
|
|
|
||||||
|
|
@ -235,6 +235,7 @@ extract_num(ikptr x) {
|
||||||
if (is_fixnum(x)) {
|
if (is_fixnum(x)) {
|
||||||
return unfix(x);
|
return unfix(x);
|
||||||
} else {
|
} else {
|
||||||
|
if (x == void_object) { return 0; }
|
||||||
if(bnfst_negative(ref(x, -vector_tag))){
|
if(bnfst_negative(ref(x, -vector_tag))){
|
||||||
return (long)(-ref(x, wordsize-vector_tag));
|
return (long)(-ref(x, wordsize-vector_tag));
|
||||||
} else {
|
} else {
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue