diff --git a/lab/gears.scm b/lab/gears.scm index 5ca4185..bfc891d 100755 --- a/lab/gears.scm +++ b/lab/gears.scm @@ -273,15 +273,11 @@ (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))) + (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 *** ) diff --git a/lib/gl.ss b/lib/gl.ss index c59da6a..de812d6 100644 --- a/lib/gl.ss +++ b/lib/gl.ss @@ -2192,7 +2192,7 @@ (define-function int glGetError ()) ;; const GLubyte * glGetString( GLenum name ) - (define-function void* glGetString (int)) + (define-function char* glGetString (int)) ;; void glFinish( void ) (define-function void glFinish ()) diff --git a/lib/ypsilon-compat.ikarus.ss b/lib/ypsilon-compat.ikarus.ss index d62b520..b4e984e 100644 --- a/lib/ypsilon-compat.ikarus.ss +++ b/lib/ypsilon-compat.ikarus.ss @@ -17,7 +17,7 @@ (define (ypsilon:format what str . args) (cond - [(eq? what #f) + [(eq? what #t) (apply printf str args)] [else (apply format str args)])) @@ -177,6 +177,31 @@ (syntax-violation 'c-function "invalid argument type" #'form #'arg-type)]))) + + (define (char*->string who x) + (define (strlen x) + (let f ([i 0]) + (cond + [(= 0 (pointer-ref-uchar x i)) i] + [else (f (+ i 1))]))) + (let ([n (strlen x)]) + (let ([s (make-string n)]) + (let f ([i 0]) + (if (= i n) + s + (begin + (string-set! s i (integer->char (pointer-ref-uchar x i))) + (f (+ i 1)))))))) + + (define-syntax convert-return + (lambda (x) + (syntax-case x (char*) + [(_ form foreign-name val char*) + #'(char*->string 'foreign-name val)] + [(_ form foreign-name val other) + #'val]))) + + (define-syntax convert-type (lambda (x) (define ls @@ -230,7 +255,7 @@ (lambda (t* ...) (let ([t* (convert-arg x foreign-name t* arg-type*)] ...) (let ([v (callout t* ...)]) - v)))))]))) + (convert-return x foreign-name v return-type))))))]))) (define-syntax c-argument (lambda (x)