=== modified file 'lib/gl.ss' --- lib/gl.ss 2008-09-24 11:55:23 +0000 +++ lib/gl.ss 2010-03-01 00:35:20 +0000 @@ -1242,8 +1242,9 @@ (on-windows (load-shared-object "opengl32.dll")) (on-linux (load-shared-object "libGL.so.1")) (on-freebsd (load-shared-object "libGL.so.1")) + (on-cygwin (load-shared-object "cygGL-1.dll")) (else (assertion-violation #f "can not locate OpenGL library, unknown operating system")))) - + ;;;; Boolean values (define GL_FALSE #x0) (define GL_TRUE #x1) @@ -2214,7 +2215,7 @@ ;; void glDepthMask( GLboolean flag ) (define-function void glDepthMask (int)) - ;; void glDepthRange( GLclampd near_val, GLclampd far_val ) + ;; void glDepthRange( GLclampd near_val, GLclampd far_val ) (define-function void glDepthRange (double double)) ;;;; Accumulation Buffer === modified file 'lib/glut.ss' --- lib/glut.ss 2008-09-24 11:22:25 +0000 +++ lib/glut.ss 2010-03-01 00:36:49 +0000 @@ -181,6 +181,7 @@ (on-windows (load-shared-object "glut32.dll")) (on-linux (load-shared-object "libglut.so.3")) (on-freebsd (load-shared-object "libglut.so.4")) + (on-cygwin (load-shared-object "cygglut-3.dll")) (else (assertion-violation #f "can not locate GLUT library, unknown operating system")))) ;; Display mode bit masks. @@ -258,12 +259,12 @@ ;; 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 === modified file 'lib/ypsilon-compat.ikarus.ss' --- lib/ypsilon-compat.ikarus.ss 2009-04-13 13:43:20 +0000 +++ lib/ypsilon-compat.ikarus.ss 2010-03-01 00:41:34 +0000 @@ -1,26 +1,26 @@ ;;; Ikarus Scheme -- A compiler for R6RS Scheme. ;;; Copyright (C) 2008,2009 Abdulaziz Ghuloum -;;; +;;; ;;; This program is free software: you can redistribute it and/or modify ;;; it under the terms of the GNU General Public License version 3 as ;;; published by the Free Software Foundation. -;;; +;;; ;;; This program is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; General Public License for more details. -;;; +;;; ;;; You should have received a copy of the GNU General Public License ;;; along with this program. If not, see . (library (ypsilon-compat) - (export on-windows on-darwin on-linux on-freebsd on-posix - load-shared-object c-argument c-function + (export on-windows on-darwin on-linux on-freebsd on-cygwin on-posix + load-shared-object c-argument c-function microsecond usleep library-pointer (rename (ypsilon:format format))) - (import + (import (ikarus system $foreign) (except (ikarus) library)) @@ -33,9 +33,9 @@ (define (ypsilon:format what str . args) (cond - [(eq? what #t) + [(eq? what #t) (apply printf str args)] - [(eq? what #f) + [(eq? what #f) (apply format str args)] [else (error 'ypsion:format "invalid what" what)])) @@ -64,26 +64,27 @@ (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-cygwin (and (string-contains (architecture-feature 'operating-system) "cygwin") #t)) (define on-posix (not on-windows)) - + (define-record-type library (fields name pointer)) - (define (load-shared-object libname) + (define (load-shared-object libname) (unless (string? libname) (error 'load-shared-object "library name must be a string" libname)) (make-library libname (or (dlopen libname) (error 'load-shared-object (dlerror) libname)))) - + (define (int? x) (or (fixnum? x) (bignum? x))) (define (check-int who x) (cond [(int? x) x] [else (die who "not an int" x)])) - + (define (vector-andmap f v) (andmap f (vector->list v))) @@ -105,7 +106,7 @@ [(string? x) (check-byte* who (string->utf8 x))] [else (die who "not a char*" x)])) - + (define pointer-size (cond [(<= (fixnum-width) 32) 4] @@ -138,7 +139,7 @@ (pointer-set-c-char! p i (bytevector-u8-ref x i)) (f (+ i 1))]))))] [else (die who "not a byte*" x)])) - + (define (check-float who x) (cond [(flonum? x) x] @@ -222,10 +223,10 @@ (let ([n (strlen x)]) (let ([s (make-string n)]) (let f ([i 0]) - (if (= i n) + (if (= i n) s (begin - (string-set! s i + (string-set! s i (integer->char (pointer-ref-c-unsigned-char x i))) (f (+ i 1)))))))) @@ -234,7 +235,7 @@ (syntax-case x (char*) [(_ form foreign-name val char*) #'(char*->string 'foreign-name val)] - [(_ form foreign-name val other) + [(_ form foreign-name val other) #'val]))) (define-syntax convert-type @@ -260,19 +261,19 @@ (syntax-case x (void) [(ctxt t) (cond - [(valid (syntax->datum #'t)) => + [(valid (syntax->datum #'t)) => (lambda (t) (with-syntax ([t (datum->syntax #'ctxt t)]) #'(quote t)))] [else (syntax-violation #f "invalid type" #'t)])]))) - (define (lookup-shared-object lib name) + (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)) (or (dlsym (library-pointer lib) (symbol->string name)) - (error who - (format "cannot find object ~a in library ~a" + (error who + (format "cannot find object ~a in library ~a" name (library-name lib))))) (define-syntax c-function @@ -282,8 +283,8 @@ (with-syntax ([x x] [(t* ...) (generate-temporaries #'(arg-type* ...))] [(u* ...) (generate-temporaries #'(arg-type* ...))]) - #'(let ([callout - ((make-c-callout + #'(let ([callout + ((make-c-callout (convert-type return-type) (list (convert-type arg-type*) ...)) (lookup-shared-object lib 'foreign-name))])