|#
-;;;; Test the BLOWFISH option.
+;;;; Test the blowfish option.
(let ((sample (string->utf8 "Some text to encrypt and decrypt.")))
(call-with-binary-output-file "test"
#!/bin/sh
#
-# Test the BLOWFISH option.
+# Test the blowfish option.
set -e
${MIT_SCHEME_EXE} --prepend-library . <<\EOF
-(load-option 'BLOWFISH)
+(load-option 'blowfish)
(load "blowfish-check" (->environment '(blowfish)))
EOF
(define p24 #u8(#xFE #xDC #xBA #x98 #x76 #x54 #x32 #x10))
(let ((k (bytevector-copy k24 0 i))
(p p24))
- (define-bf-test (symbol 'VARIABLE-KEY ': i ': 'ENCRYPT)
+ (define-bf-test (symbol 'variable-key ': i ': 'encrypt)
(lambda ()
(let ((bf (blowfish-set-key k))
(buf (make-bytevector 8)))
(blowfish-ecb p buf bf #t)
(assert-equal buf c))))
- (define-bf-test (symbol 'VARIABLE-KEY ': i ': 'DECRYPT)
+ (define-bf-test (symbol 'variable-key ': i ': 'decrypt)
(lambda ()
(let ((bf (blowfish-set-key k))
(buf (make-bytevector 8)))
((lambda (ks ps cs)
((lambda (doit) (for-each doit (iota (length ks)) ks ps cs))
(lambda (i k p c)
- (define-bf-test (symbol 'ENCRYPT ': i)
+ (define-bf-test (symbol 'encrypt ': i)
(lambda ()
(let ((bf (blowfish-set-key k))
(buf (make-bytevector 8)))
(blowfish-ecb p buf bf #t)
(assert-equal buf c))))
- (define-bf-test (symbol 'DECRYPT ': i)
+ (define-bf-test (symbol 'decrypt ': i)
(lambda ()
(let ((bf (blowfish-set-key k))
(buf (make-bytevector 8)))
(define iv #u8(7 6 5 4 3 2 1 0))
(define p #u8(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23))
(let ((p (bytevector-copy p 0 i)))
- (define-bf-test (symbol 'CBC:ENCRYPT ': i)
+ (define-bf-test (symbol 'cbc:encrypt ': i)
(lambda ()
(let ((bf (blowfish-set-key k))
(iv (bytevector-copy iv))
(blowfish-cbc p buf bf iv #t)
(assert-equal buf c)
(assert-equal iv (bytevector-copy buf (- i 8) i)))))
- (define-bf-test (symbol 'CBC:DECRYPT ': i)
+ (define-bf-test (symbol 'cbc:decrypt ': i)
(lambda ()
(let ((bf (blowfish-set-key k))
(iv (bytevector-copy iv))
#| -*-Scheme-*- |#
-;;;; Compile the BLOWFISH option.
+;;;; Compile the blowfish option.
(for-each load-option '(cref ffi))
#| -*-Scheme-*- |#
-;;;; Load the BLOWFISH option.
+;;;; Load the blowfish option.
(with-working-directory-pathname (directory-pathname (current-load-pathname))
(lambda ()
#| -*-Scheme-*- |#
-(define-load-option 'BLOWFISH
+(define-load-option 'blowfish
(standard-system-loader "."))
(further-load-options #t)
\ No newline at end of file
(loop scms chs cdecls (cons section rest))))))))))
(parameterize ((param:suppress-loading-message? #t))
- (load-option 'FFI))
+ (load-option 'ffi))
((access rewrite-file (->environment '(ffi build)))
(merge-pathnames "TAGS")
rewriter)))
#!/bin/sh
# -*-Scheme-*-
#
-# Test the CAIRO option.
+# Test the Cairo option.
set -e
: ${MIT_SCHEME_EXE=mit-scheme}
${MIT_SCHEME_EXE} --prepend-library . <<\EOF
-(load-option 'CAIRO)
+(load-option 'cairo)
EOF
(define (cairo-graphics/set-drawing-mode device mode)
(let ((operator
(case mode
- ((0) 'CLEAR) ;GXclear 0
- ((1) 'IN) ;GXand src AND dst
- ((2) 'OUT) ;GXandReverse src AND NOT dst
- ((3) 'SOURCE) ;GXcopy src
- ((4) 'DEST-OUT) ;GXandInverted NOT src AND dst
- ((5) 'DEST) ;GXnoop dst
- ((6) 'XOR) ;GXxor src XOR dst
- ((7) 'OVER) ;GXor src OR dst
- ((8) (warn "unimplemented:" '|GXnor|) #f) ;GXnor NOT src AND NOT dst
- ((9) (warn "unimplemented:" '|GXequiv|) #f) ;GXequiv NOT src XOR dst
- ((10) (warn "unimplemented:" '|GXinvert|) #f) ;GXinvert NOT dst
- ((11) (warn "unimplemented:" '|GXorReverse|) #f) ;GXorReverse src OR NOT dst
- ((12) (warn "unimplemented:" '|GXcopyInverted|) #f) ;GXcopyInverted NOT src
- ((13) (warn "unimplemented:" '|GXorInverted|) #f) ;GXorInverted NOT src OR dst
- ((14) (warn "unimplemented:" '|GXnand|) #f) ;GXnand NOT src OR NOT dst
- ((15) 'SOURCE) ;GXset 1
+ ((0) 'clear) ;GXclear 0
+ ((1) 'in) ;GXand src and dst
+ ((2) 'out) ;GXandReverse src and not dst
+ ((3) 'source) ;GXcopy src
+ ((4) 'dest-out) ;GXandInverted not src and dst
+ ((5) 'dest) ;GXnoop dst
+ ((6) 'xor) ;GXxor src xor dst
+ ((7) 'over) ;GXor src or dst
+ ((8) (warn "unimplemented:" '|GXnor|) #f) ;GXnor not src and not dst
+ ((9) (warn "unimplemented:" '|GXequiv|) #f) ;GXequiv not src xor dst
+ ((10) (warn "unimplemented:" '|GXinvert|) #f) ;GXinvert not dst
+ ((11) (warn "unimplemented:" '|GXorReverse|) #f) ;GXorReverse src or not dst
+ ((12) (warn "unimplemented:" '|GXcopyInverted|) #f) ;GXcopyInverted not src
+ ((13) (warn "unimplemented:" '|GXorInverted|) #f) ;GXorInverted not src or dst
+ ((14) (warn "unimplemented:" '|GXnand|) #f) ;GXnand not src or not dst
+ ((15) 'source) ;GXset 1
(else (error:wrong-type-argument mode "a drawing mode"
'cairo-graphics/set-drawing-mode)))))
(if operator
(define (initialize-package!)
(set! cairo-graphics-device-type
(make-graphics-device-type
- 'CAIRO
+ 'cairo
`((available? ,cairo-graphics/available?)
(open ,cairo-graphics/open)
(clear ,cairo-graphics/clear)
(guarantee-cairo cairo 'cairo-set-operator)
(C-call "cairo_set_operator" cairo
(case operator
- ((CLEAR) (C-enum "CAIRO_OPERATOR_CLEAR"))
- ((SOURCE) (C-enum "CAIRO_OPERATOR_SOURCE"))
- ((OVER) (C-enum "CAIRO_OPERATOR_OVER"))
- ((IN) (C-enum "CAIRO_OPERATOR_IN"))
- ((OUT) (C-enum "CAIRO_OPERATOR_OUT"))
- ((ATOP) (C-enum "CAIRO_OPERATOR_ATOP"))
- ((DEST) (C-enum "CAIRO_OPERATOR_DEST"))
- ((DEST-OVER) (C-enum "CAIRO_OPERATOR_DEST_OVER"))
- ((DEST-IN) (C-enum "CAIRO_OPERATOR_DEST_IN"))
- ((DEST-OUT) (C-enum "CAIRO_OPERATOR_DEST_OUT"))
- ((DEST-ATOP) (C-enum "CAIRO_OPERATOR_DEST_ATOP"))
- ((XOR) (C-enum "CAIRO_OPERATOR_XOR"))
- ((ADD) (C-enum "CAIRO_OPERATOR_ADD"))
- ((SOURCE) (C-enum "CAIRO_OPERATOR_SOURCE"))
- ((SATURATE) (C-enum "CAIRO_OPERATOR_SATURATE"))
- ((MULTIPLY) (C-enum "CAIRO_OPERATOR_MULTIPLY"))
- ((SCREEN) (C-enum "CAIRO_OPERATOR_SCREEN"))
- ((OVERLAY) (C-enum "CAIRO_OPERATOR_OVERLAY"))
- ((DARKEN) (C-enum "CAIRO_OPERATOR_DARKEN"))
- ((LIGHTEN) (C-enum "CAIRO_OPERATOR_LIGHTEN"))
- ((COLOR-DODGE) (C-enum "CAIRO_OPERATOR_COLOR_DODGE"))
- ((COLOR-BURN) (C-enum "CAIRO_OPERATOR_COLOR_BURN"))
- ((HARD-LIGHT) (C-enum "CAIRO_OPERATOR_HARD_LIGHT"))
- ((SOFT-LIGHT) (C-enum "CAIRO_OPERATOR_SOFT_LIGHT"))
- ((DIFFERENCE) (C-enum "CAIRO_OPERATOR_DIFFERENCE"))
- ((EXCLUSION) (C-enum "CAIRO_OPERATOR_EXCLUSION"))
- ((HSL-HUE) (C-enum "CAIRO_OPERATOR_HSL_HUE"))
- ((HSL-SATURATION) (C-enum "CAIRO_OPERATOR_HSL_SATURATION"))
- ((HSL-COLOR) (C-enum "CAIRO_OPERATOR_HSL_COLOR"))
- ((HSL-LUMINOSITY) (C-enum "CAIRO_OPERATOR_HSL_LUMINOSITY"))
+ ((clear) (C-enum "CAIRO_OPERATOR_CLEAR"))
+ ((source) (C-enum "CAIRO_OPERATOR_SOURCE"))
+ ((over) (C-enum "CAIRO_OPERATOR_OVER"))
+ ((in) (C-enum "CAIRO_OPERATOR_IN"))
+ ((out) (C-enum "CAIRO_OPERATOR_OUT"))
+ ((atop) (C-enum "CAIRO_OPERATOR_ATOP"))
+ ((dest) (C-enum "CAIRO_OPERATOR_DEST"))
+ ((dest-over) (C-enum "CAIRO_OPERATOR_DEST_OVER"))
+ ((dest-in) (C-enum "CAIRO_OPERATOR_DEST_IN"))
+ ((dest-out) (C-enum "CAIRO_OPERATOR_DEST_OUT"))
+ ((dest-atop) (C-enum "CAIRO_OPERATOR_DEST_ATOP"))
+ ((xor) (C-enum "CAIRO_OPERATOR_XOR"))
+ ((add) (C-enum "CAIRO_OPERATOR_ADD"))
+ ((source) (C-enum "CAIRO_OPERATOR_SOURCE"))
+ ((saturate) (C-enum "CAIRO_OPERATOR_SATURATE"))
+ ((multiply) (C-enum "CAIRO_OPERATOR_MULTIPLY"))
+ ((screen) (C-enum "CAIRO_OPERATOR_SCREEN"))
+ ((overlay) (C-enum "CAIRO_OPERATOR_OVERLAY"))
+ ((darken) (C-enum "CAIRO_OPERATOR_DARKEN"))
+ ((lighten) (C-enum "CAIRO_OPERATOR_LIGHTEN"))
+ ((color-dodge) (C-enum "CAIRO_OPERATOR_COLOR_DODGE"))
+ ((color-burn) (C-enum "CAIRO_OPERATOR_COLOR_BURN"))
+ ((hard-light) (C-enum "CAIRO_OPERATOR_HARD_LIGHT"))
+ ((soft-light) (C-enum "CAIRO_OPERATOR_SOFT_LIGHT"))
+ ((difference) (C-enum "CAIRO_OPERATOR_DIFFERENCE"))
+ ((exclusion) (C-enum "CAIRO_OPERATOR_EXCLUSION"))
+ ((hsl-hue) (C-enum "CAIRO_OPERATOR_HSL_HUE"))
+ ((hsl-saturation) (C-enum "CAIRO_OPERATOR_HSL_SATURATION"))
+ ((hsl-color) (C-enum "CAIRO_OPERATOR_HSL_COLOR"))
+ ((hsl-luminosity) (C-enum "CAIRO_OPERATOR_HSL_LUMINOSITY"))
(else (error:wrong-type-argument operator "a drawing operator"
'cairo-set-operator)))))
(- s) c 0.)))
(define (cairo-matrix-scale! matrix factor)
- (guarantee-flonum factor 'CAIRO-SCALE-MATRIX!)
+ (guarantee-flonum factor 'cairo-scale-matrix!)
(set-xx! matrix (flo:* (xx matrix) factor))
(set-yy! matrix (flo:* (yy matrix) factor)))
(define (cairo-matrix-translate! matrix dx dy)
- (guarantee-flonum dx 'CAIRO-MATRIX-TRANSLATE!)
- (guarantee-flonum dy 'CAIRO-MATRIX-TRANSLATE!)
+ (guarantee-flonum dx 'cairo-matrix-translate!)
+ (guarantee-flonum dy 'cairo-matrix-translate!)
(set-x0! matrix (flo:+ dx (x0 matrix)))
(set-y0! matrix (flo:+ dy (y0 matrix))))
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
# 02110-1301, USA.
-# Compile the CAIRO option.
+# Compile the Cairo option.
set -e
: ${MIT_SCHEME_EXE=mit-scheme}
(begin
(parameterize ((param:suppress-loading-message? #t))
- (load-option 'CREF)
- (load-option 'PANGO)
- (load-option 'FFI))
+ (for-each load-option '(cref pango ffi))
- (if (name->package '(CAIRO))
- (error "The CAIRO package already exists."))
+ (if (name->package '(cairo))
+ (error "The Cairo package already exists."))
(let ((package-set (package-set-pathname "cairo")))
(if (not (file-modification-time<? "cairo.pkg" package-set))
(cref/generate-trivial-constructor "cairo"))
Load the Cairo option. |#
-(load-option 'PANGO)
+(load-option 'pango)
(with-loader-base-uri (system-library-uri "cairo/")
(lambda ()
(load-package-set "cairo")))
#| -*-Scheme-*- |#
-(define-load-option 'CAIRO
+(define-load-option 'cairo
(let ((pathname
(merge-pathnames "make"
(directory-pathname (current-load-pathname)))))
(define (include-cdecls library)
;; Toplevel entry point for the generator.
- ;; Returns a new C-INCLUDES structure.
+ ;; Returns a new c-includes structure.
(let ((includes (make-c-includes library))
(cwd (if (param:loading?)
(directory-pathname (current-load-pathname))
(let* ((structs (c-includes/structs includes))
(entry (assq name structs)))
(if entry (cerror form "already defined in " (cddr entry)))
- (let* ((anon (cons 'STRUCT
+ (let* ((anon (cons 'struct
(map (lambda (member)
(valid-struct-member member includes))
members)))
(let* ((unions (c-includes/unions includes))
(entry (assq name unions)))
(if entry (cerror form "already defined in " (cddr entry)))
- (let* ((anon (cons 'UNION
+ (let* ((anon (cons 'union
(map (lambda (member)
(valid-union-member member includes))
members)))
(let* ((enums (c-includes/enums includes))
(entry (assq name enums)))
(if entry (cerror form "already defined in " (cddr entry)))
- (let* ((anon (cons 'ENUM
+ (let* ((anon (cons 'enum
(valid-enum-constants constants includes)))
(info (cons anon current-filename)))
(set-c-includes/enums!
(cerror form "malformed " (symbol->string (car form)) " declaration"))
(let* ((name (car rest))
(params (cdr rest))
- (others (if (eq? 'EXTERN (car form))
+ (others (if (eq? 'extern (car form))
(c-includes/callouts includes)
(c-includes/callbacks includes)))
(entry (assq name others)))
(valid-ctype rettype includes)
(valid-params params includes)
current-filename))))
- (if (eq? 'EXTERN (car form))
+ (if (eq? 'extern (car form))
(set-c-includes/callouts! includes (cons new others))
(set-c-includes/callbacks! includes (cons new others)))
unspecific)))
(cond ((symbol? form) form)
((ctype/pointer? form) form)
((ctype/const? form)
- (list 'CONST (valid-ctype (cadr form) includes)))
+ (list 'const (valid-ctype (cadr form) includes)))
((ctype/struct-name? form) form)
((ctype/struct-anon? form)
- (cons 'STRUCT (map (lambda (member)
+ (cons 'struct (map (lambda (member)
(valid-struct-member member includes))
(cdr form))))
((ctype/struct-named? form)
(include-struct form (cadr form) (cddr form) includes)
- (list 'STRUCT (cadr form)))
+ (list 'struct (cadr form)))
((ctype/union-name? form) form)
((ctype/union-anon? form)
- (cons 'UNION (map (lambda (member)
+ (cons 'union (map (lambda (member)
(valid-union-member member includes))
(cdr form))))
((ctype/union-named? form)
(include-union form (cadr form) (cddr form))
- (list 'UNION (cadr form)))
+ (list 'union (cadr form)))
((ctype/enum-name? form) form)
((ctype/enum-anon? form)
- (cons 'ENUM (valid-enum-constants (cdr form) includes)))
+ (cons 'enum (valid-enum-constants (cdr form) includes)))
((ctype/enum-named? form)
(include-enum form (cadr form) (cddr form) includes)
- (list 'ENUM (cadr form)))
+ (list 'enum (cadr form)))
((ctype/array? form)
- (list 'ARRAY
+ (list 'array
(valid-ctype (ctype-array/element-type form) includes)
(ctype-array/size form)))
(make-condition-type
'ffi-cdecl-error
condition-type:error
- '(FORM FILENAME MESSAGE)
+ '(form filename message)
(lambda (condition port)
(write-string "Error: " port)
- (write-string (access-condition condition 'MESSAGE) port)
+ (write-string (access-condition condition 'message) port)
(write-string ":" port)
- (write-string (access-condition condition 'FILENAME) port)
+ (write-string (access-condition condition 'filename) port)
(write-string ": " port)
- (write (access-condition condition 'FORM) port))))
+ (write (access-condition condition 'form) port))))
(define cerror
(let ((signaller (condition-signaller condition-type:cerror
- '(FORM FILENAME MESSAGE)
+ '(form filename message)
standard-error-handler)))
(named-lambda (cerror form message . args)
(signaller form current-filename
(make-condition-type
'ffi-cdecl-warning
condition-type:warning
- '(FORM FILENAME MESSAGE)
+ '(form filename message)
(lambda (condition port)
- (write-string (access-condition condition 'MESSAGE) port)
+ (write-string (access-condition condition 'message) port)
(write-string ":" port)
- (write-string (access-condition condition 'FILENAME) port)
+ (write-string (access-condition condition 'filename) port)
(write-string ": " port)
- (write (access-condition condition 'FORM) port))))
+ (write (access-condition condition 'form) port))))
(define cwarn
(let ((signaller (condition-signaller condition-type:cwarn
- '(FORM FILENAME MESSAGE)
+ '(form filename message)
standard-warning-handler)))
(named-lambda (cwarn form message . args)
- (with-simple-restart 'MUFFLE-WARNING "Ignore warning."
+ (with-simple-restart 'muffle-warning "Ignore warning."
(lambda ()
(signaller form current-filename
(apply string-append
(define ctype-pointer/target-type cadr)
(define (ctype/void? ctype)
- (eq? ctype 'VOID))
+ (eq? ctype 'void))
(define (ctype/const? ctype)
- (and (pair? ctype) (eq? 'CONST (car ctype))
+ (and (pair? ctype) (eq? 'const (car ctype))
(pair? (cdr ctype)) (null? (cddr ctype))))
(define ctype-const/qualified-type cadr)
(define (ctype/struct-name? ctype)
;; Returns #t iff CTYPE is a struct name, e.g. (struct _GValue).
- (and (pair? ctype) (eq? 'STRUCT (car ctype))
+ (and (pair? ctype) (eq? 'struct (car ctype))
(pair? (cdr ctype)) (symbol? (cadr ctype))
(null? (cddr ctype))))
(define (ctype/struct-anon? ctype)
;; Returns #t iff CTYPE is an anonymous struct
;; -- (struct (MEMBER . TYPE)...).
- (and (pair? ctype) (eq? 'STRUCT (car ctype))
+ (and (pair? ctype) (eq? 'struct (car ctype))
(pair? (cdr ctype)) (pair? (cadr ctype))))
(define (ctype/struct-named? ctype)
;; Returns #t iff CTYPE is a named struct
;; -- (struct NAME (MEMBER VALUE)...).
- (and (pair? ctype) (eq? 'STRUCT (car ctype))
+ (and (pair? ctype) (eq? 'struct (car ctype))
(pair? (cdr ctype)) (symbol? (cadr ctype))
(pair? (cddr ctype)) (pair? (caddr ctype))))
(define (ctype-struct/name ctype)
;; This works on a struct name as well as definitions.
- (and (or (and (eq? 'STRUCT (car ctype))
+ (and (or (and (eq? 'struct (car ctype))
(pair? (cdr ctype)))
(error:wrong-type-argument ctype "C struct type" 'ctype-struct/name))
(symbol? (cadr ctype))
(define (make-ctype-struct name members)
(if name
- (cons* 'STRUCT name members)
- (cons 'STRUCT members)))
+ (cons* 'struct name members)
+ (cons 'struct members)))
(define (ctype/union-name? ctype)
;; Returns #t iff CTYPE is a union name, e.g. (union _GdkEvent).
- (and (pair? ctype) (eq? 'UNION (car ctype))
+ (and (pair? ctype) (eq? 'union (car ctype))
(pair? (cdr ctype)) (symbol? (cadr ctype))
(null? (cddr ctype))))
(define (ctype/union-anon? ctype)
;; Returns #t iff CTYPE is an anonymous union
;; -- (union (MEMBER . TYPE)...).
- (and (pair? ctype) (eq? 'UNION (car ctype))
+ (and (pair? ctype) (eq? 'union (car ctype))
(pair? (cdr ctype)) (pair? (cadr ctype))))
(define (ctype/union-named? ctype)
;; Returns #t iff CTYPE is a named union
;; -- (union NAME (MEMBER TYPE)...).
- (and (pair? ctype) (eq? 'UNION (car ctype))
+ (and (pair? ctype) (eq? 'union (car ctype))
(pair? (cdr ctype)) (symbol? (cadr ctype))
(pair? (cddr ctype)) (pair? (caddr ctype))))
(define (ctype-union/name ctype)
;; This works on union names as well as definitions.
- (and (or (and (eq? 'UNION (car ctype))
+ (and (or (and (eq? 'union (car ctype))
(pair? (cdr ctype)))
(error:wrong-type-argument ctype "C union type" 'ctype-union/name))
(symbol? (cadr ctype))
(define (make-ctype-union name members)
(if name
- (cons* 'UNION name members)
- (cons 'UNION members)))
+ (cons* 'union name members)
+ (cons 'union members)))
(define (ctype/enum-name? ctype)
;; Returns #t iff CTYPE is an enum name, e.g. (enum GdkEventType).
- (and (pair? ctype) (eq? 'ENUM (car ctype))
+ (and (pair? ctype) (eq? 'enum (car ctype))
(pair? (cdr ctype)) (symbol? (cadr ctype))
(null? (cddr ctype))))
(define (ctype/enum-anon? ctype)
;; Returns #t iff CTYPE is an anonymous enum
;; -- (enum (CONSTANT . VALUE)...).
- (and (pair? ctype) (eq? 'ENUM (car ctype))
+ (and (pair? ctype) (eq? 'enum (car ctype))
(pair? (cdr ctype)) (pair? (cadr ctype))))
(define (ctype/enum-named? ctype)
;; Returns #t iff CTYPE is a named enum
;; -- (enum NAME (CONSTANT . VALUE)...).
- (and (pair? ctype) (eq? 'ENUM (car ctype))
+ (and (pair? ctype) (eq? 'enum (car ctype))
(pair? (cdr ctype)) (symbol? (cadr ctype))
(pair? (cddr ctype)) (pair? (caddr ctype))))
(define (ctype-enum/name ctype)
;; This works on enum names as well as definitions.
- (and (or (and (eq? 'ENUM (car ctype))
+ (and (or (and (eq? 'enum (car ctype))
(pair? (cdr ctype)))
(error:wrong-type-argument ctype "C enum type" 'ctype-enum/name))
(symbol? (cadr ctype))
(define (make-ctype-enum name constants)
(if name
- (cons* 'ENUM name constants)
- (cons 'ENUM constants)))
+ (cons* 'enum name constants)
+ (cons 'enum constants)))
(define (ctype/array? ctype)
;; Returns #t iff CTYPE is an array type, e.g. (ARRAY (* GtkWidget) 5).
- (and (pair? ctype) (eq? 'ARRAY (car ctype))
+ (and (pair? ctype) (eq? 'array (car ctype))
(pair? (cdr ctype))
(or (null? (cddr ctype))
(and (pair? (cddr ctype)) (null? (cdddr ctype))))))
(and (pair? (cddr ctype)) (caddr ctype)))
(define (make-ctype-array ctype size)
- (list 'ARRAY ctype size))
+ (list 'array ctype size))
(define (ctype/primitive-accessor ctype)
;; Returns the primitive to use when reading from CTYPE, a basic ctype.
(ctype ctype))
(cond ((or (ctype/basic? ctype)
(ctype/void? ctype)
- (eq? 'ENUM ctype)
+ (eq? 'enum ctype)
(eq? '* ctype)) ctype)
((symbol? ctype)
(if (memq ctype stack)
(ctype/union-defn? type)
(ctype/enum-defn? type)
;; Enum constants are not enumerated in -const.scm files.
- (eq? 'ENUM type)) type)
+ (eq? 'enum type)) type)
((ctype/struct-name? type)
(let ((entry (assq (cadr type) (c-includes/structs includes))))
(if (not entry)
(define (gen-callout-trampolines includes)
(for-each
(lambda (name.alienf)
- (with-simple-restart 'CONTINUE "Continue generating callout trampolines."
+ (with-simple-restart 'continue "Continue generating callout trampolines."
(lambda ()
(bind-condition-handler
(list condition-type:simple-error)
(lambda (condition)
- (let ((restart (find-restart 'CONTINUE condition))
- (msg (access-condition condition 'MESSAGE))
- (irr (access-condition condition 'IRRITANTS)))
+ (let ((restart (find-restart 'continue condition))
+ (msg (access-condition condition 'message))
+ (irr (access-condition condition 'irritants)))
(apply warn msg irr)
(if restart
(invoke-restart restart))))
((ctype/enum? ctype) "arg_long")
((ctype/basic? ctype)
(case ctype
- ((CHAR SHORT INT LONG) "arg_long")
- ((UCHAR USHORT UINT ULONG) "arg_ulong")
- ((FLOAT DOUBLE) "arg_double")
+ ((char short int long) "arg_long")
+ ((uchar ushort uint ulong) "arg_ulong")
+ ((float double) "arg_double")
(else (error "Unexpected parameter type:" arg-ctype))))
((or (ctype/struct? ctype) (ctype/union? ctype))
(string-append "*("decl"*) arg_pointer"))
(cond ((ctype/enum? ctype) "ulong_to_scm")
((ctype/basic? ctype)
(case ctype
- ((CHAR SHORT INT LONG) "long_to_scm")
- ((UCHAR USHORT UINT ULONG) "ulong_to_scm")
- ((FLOAT DOUBLE) "double_to_scm")
- ((VOID) #f)
+ ((char short int long) "long_to_scm")
+ ((uchar ushort uint ulong) "ulong_to_scm")
+ ((float double) "double_to_scm")
+ ((void) #f)
(else (error "Unexpected C type:" ctype))))
(else (error "Unexpected C type:" ctype))))
(define (gen-callback-trampolines includes)
(for-each
(lambda (name.alienf)
- (with-simple-restart 'CONTINUE "Continue generating callback trampolines."
+ (with-simple-restart 'continue "Continue generating callback trampolines."
(lambda ()
(bind-condition-handler
(list condition-type:simple-error)
(lambda (condition)
- (let ((restart (find-restart 'CONTINUE condition))
- (msg (access-condition condition 'MESSAGE))
- (irr (access-condition condition 'IRRITANTS)))
+ (let ((restart (find-restart 'continue condition))
+ (msg (access-condition condition 'message))
+ (irr (access-condition condition 'irritants)))
(apply warn msg irr)
(if restart
(invoke-restart restart))))
((ctype/void? ctype) #f)
((ctype/basic? ctype)
(case ctype
- ((CHAR SHORT INT LONG) "long_value")
- ((UCHAR USHORT UINT ULONG) "ulong_value")
- ((FLOAT DOUBLE) "double_value")
+ ((char short int long) "long_value")
+ ((uchar ushort uint ulong) "ulong_value")
+ ((float double) "double_value")
(else (error "Unexpected callback return type:" ctype))))
(else (error "Unexpected callback return type:" ctype)))))
\f
(append-map*!
(map (lambda (name.info)
;; The named structs, top-level OR internal.
- (let ((name (list 'STRUCT (car name.info))))
+ (let ((name (list 'struct (car name.info))))
(gen-struct-union-grovel-func name includes)))
(c-includes/structs includes))
(lambda (name.info)
(append-map*!
(map (lambda (name.info)
;; The named unions, top-level OR internal.
- (let ((name (list 'UNION (car name.info))))
+ (let ((name (list 'union (car name.info))))
(gen-struct-union-grovel-func name includes)))
(c-includes/unions includes))
(lambda (name.info)
(ctype (definite-ctype name includes))
(decl (decl-string name))
(_ (lambda args (for-each write-string args))))
- (let ((key (list 'SIZEOF name)))
+ (let ((key (list 'sizeof name)))
(_ "
void
"fname" (FILE * out)
(lambda (path brief-type)
(let ((path (decorated-string-append
"" "." "" (map symbol->string path)))
- (key (cons* 'OFFSET name path)))
+ (key (cons* 'offset name path)))
(_ "
fprintf (out, \" (")(write key)(_" %ld . ")(write brief-type)(_")\\n\", (long)((char*)&(S."path") - (char*)&S));"))))
(_ "
(ctype/array? ctype))
(receiver (list name) type))
((ctype/enum? ctype)
- (receiver (list name) 'ENUM))
+ (receiver (list name) 'enum))
((ctype/struct-defn? ctype)
(receiver (list name) type)
(let ((new-stack (cons type stack)))
form
(lambda (library)
(let ((ienv (senv->runtime usage-env)))
- (if (and (environment-bound? ienv 'C-INCLUDES)
- (environment-assigned? ienv 'C-INCLUDES))
- (let ((value (environment-lookup ienv 'C-INCLUDES))
+ (if (and (environment-bound? ienv 'C-includes)
+ (environment-assigned? ienv 'C-includes))
+ (let ((value (environment-lookup ienv 'C-includes))
(err (lambda (msg val)
(error (string-append
"C-includes is already bound, " msg) val))))
(c-includes/library value)))
(err "but not to a c-include structure:" value)))
(begin
- (environment-define ienv 'C-INCLUDES (load-c-includes library))
+ (environment-define ienv 'C-includes (load-c-includes library))
#f))))))))
(define (call-with-destructured-c-include-form form receiver)
- ;; Calls RECEIVER with the library.
+ ;; Calls receiver with the library.
(cond ((null? (cdr form))
(serror form "A library name is required"))
((not (string? (cadr form)))
(ctype/union-defn? type))
(if (null? member-spec)
(swarn whole-form "Cannot peek a whole struct")
- (let ((entry (assoc (cons* 'OFFSET ctype member-spec)
+ (let ((entry (assoc (cons* 'offset ctype member-spec)
(c-includes/struct-values includes))))
(if (not entry)
(swarn whole-form "No such member")
`(,prim ,alien-form ,offset ,value-form)))
((ctype/array? ctype)
(swarn whole-form "Cannot poke a whole array"))
- ((or (ctype/enum? ctype) (eq? ctype 'ENUM))
+ ((or (ctype/enum? ctype) (eq? ctype 'enum))
(let ((prim (ucode-primitive c-poke-uint 3)))
`(,prim ,alien-form ,offset ,value-form)))
(else (swarn whole-form "Unexpected C type for poking" ctype))))
(swarn whole-form "Cannot peek basic type" ctype))))
((ctype/pointer? ctype)
`(,(ucode-primitive c-peek-pointer 3)
- ,alien-form ,offset ,(or value-form '(MAKE-ALIEN))))
+ ,alien-form ,offset ,(or value-form '(make-alien))))
((or (ctype/array? ctype) (ctype/struct? ctype))
(if value-form
- `(LET ((VALUE ,value-form))
- (COPY-ALIEN-ADDRESS! VALUE ,alien-form)
- (ALIEN-BYTE-INCREMENT! VALUE ,offset)
- VALUE)
- `(ALIEN-BYTE-INCREMENT ,alien-form ,offset)))
- ((or (ctype/enum? ctype) (eq? ctype 'ENUM))
+ `(let ((value ,value-form))
+ (copy-alien-address! value ,alien-form)
+ (alien-byte-increment! value ,offset)
+ value)
+ `(alien-byte-increment ,alien-form ,offset)))
+ ((or (ctype/enum? ctype) (eq? ctype 'enum))
`(,(ucode-primitive c-peek-uint 2) ,alien-form ,offset))
(else (swarn whole-form "Unexpected C type for peeking" ctype))))
(define (call-with-destructured-c->-form form receiver)
- ;; Calls RECEIVER with ALIEN, SPEC and VALUE (or #f) as in these forms:
+ ;; Calls receiver with alien, spec and value (or #f) as in these forms:
;;
- ;; (C-> ALIEN SPEC) VALUE = #f
- ;; (C-> ALIEN SPEC* VALUE) SPEC* specifies a pointer-type member
- ;; (C->= ALIEN SPEC VALUE)
+ ;; (C-> alien spec) value = #f
+ ;; (C-> alien spec* value) spec* specifies a pointer-type member
+ ;; (C->= alien spec value)
;;
(let ((len (length form)))
(if (< len 3)
;; (C-enum "GDK_MAP")
;; ===> 14
;; (C-enum "GdkEventType" 14)
- ;; ===> GDK_MAP
- ;; (C-enum "GdkEventType" FORM)
- ;; ===> (C-enum-name FORM '|GdkEventType|
+ ;; ===> |GDK_MAP|
+ ;; (C-enum "GdkEventType" form)
+ ;; ===> (C-enum-name form '|GdkEventType|
;; '((|GDK_NOTHING| . -1) (|GDK_DELETE| . 0)...))
(sc-macro-transformer
(lambda (form usage-env)
(c-enum-constant-values name form includes))
(let ((value (close-syntax value-form usage-env))
(constants (c-enum-constant-values name form includes)))
- `(C-ENUM-NAME ,value ',name ',constants))))))))))
+ `(C-enum-name ,value ',name ',constants))))))))))
(define (lookup-enum-value name includes)
(let ((entry (assq name (c-includes/enum-values includes))))
(let ((name (cond ((and (string=? "enum" (car words))
(not (null? (cdr words)))
(null? (cddr words)))
- `(ENUM ,(string->symbol (cadr words))))
+ `(enum ,(string->symbol (cadr words))))
((null? (cdr words))
(string->symbol (car words)))
(else (swarn form
;; (C-sizeof "GdkColor") ===> 10
(sc-macro-transformer
(lambda (form usage-env)
- (expand-c-info-syntax 'SIZEOF form usage-env))))
+ (expand-c-info-syntax 'sizeof form usage-env))))
(define-syntax C-offset
;; (C-offset "GdkColor green") ===> 6
(sc-macro-transformer
(lambda (form usage-env)
- (expand-c-info-syntax 'OFFSET form usage-env))))
+ (expand-c-info-syntax 'offset form usage-env))))
(define (expand-c-info-syntax which form usage-env)
- ;; WHICH can be SIZEOF or OFFSET.
+ ;; WHICH can be 'sizeof or 'offset.
(let ((len (length form)))
(if (< len 2)
(swarn form "Too few args")
(c-info which spec form usage-env))))))))
(define (c-info which spec form usage-env)
- ;; Returns the offset or sizeof for SPEC.
+ ;; Returns the offset or sizeof for spec.
(let* ((includes (find-c-includes usage-env))
(btype.members
(call-with-initial-ctype
spec form
(lambda (ctype member-spec)
(let ((defn (ctype-definition ctype includes)))
- (cond ((and (eq? which 'OFFSET) (null? member-spec))
+ (cond ((and (eq? which 'offset) (null? member-spec))
(swarn form "no member specified"))
- ((and (eq? which 'OFFSET)
+ ((and (eq? which 'offset)
(not (or (ctype/struct-defn? defn)
(ctype/union-defn? defn))))
(swarn form "not a struct or union type"))
- ((and (not (eq? which 'OFFSET)) (not (null? member-spec)))
+ ((and (not (eq? which 'offset)) (not (null? member-spec)))
(if (null? (cdr member-spec))
(swarn form "no member name allowed")
(swarn form "no member names allowed")))
(cond ((not btype.members)
form)
(entry
- (if (eq? 'OFFSET which) (cadr entry) (cdr entry)))
+ (if (eq? 'offset which) (cadr entry) (cdr entry)))
(else
- (if (eq? 'OFFSET which)
+ (if (eq? 'offset which)
(swarn form "Unknown member")
(swarn form "Unknown C type" btype.members))))))
(define (call-with-initial-ctype spec form receiver)
- ;; Given SPEC, a list of symbols, calls RECEIVER with a ctype and
+ ;; Given spec, a list of symbols, calls receiver with a ctype and
;; member spec (the list of names that followed the C type spec)
;;
- ;; For example RECEIVER is called with
+ ;; For example receiver is called with
;;
;; (* (|struct| |addrinfo|)) and (|ai_socktype|)
;;
- ;; when SPEC is (* |struct| |addrinfo| |ai_socktype|).
+ ;; when spec is (* |struct| |addrinfo| |ai_socktype|).
(let ((type-name (car spec))
(member-spec (cdr spec)))
- (cond ((memq type-name '(STRUCT UNION ENUM))
+ (cond ((memq type-name '(struct union enum))
(if (null? member-spec)
(swarn form "Incomplete C type specification")
(receiver (list type-name (car member-spec))
;;; C-array-loc and -loc! Syntaxes
(define-syntax C-array-loc
- ;; (C-array-loc ALIEN "element type" INDEX)
+ ;; (C-array-loc alien "element type" index)
;; ===>
- ;; (alien-byte-increment ALIEN (* (C-sizeof "element type") INDEX))
+ ;; (alien-byte-increment alien (* (C-sizeof "element type") index))
(sc-macro-transformer
(lambda (form usage-env)
(expand-c-array-loc-syntax #f form usage-env))))
(define-syntax C-array-loc!
- ;; (C-array-loc! ALIEN "element type" INDEX)
+ ;; (C-array-loc! alien "element type" index)
;; ===>
- ;; (alien-byte-increment! ALIEN (* (C-sizeof "element type") INDEX))
+ ;; (alien-byte-increment! alien (* (C-sizeof "element type") index))
(sc-macro-transformer
(lambda (form usage-env)
(expand-c-array-loc-syntax #t form usage-env))))
(if (null? spec)
(swarn form "2nd arg is an empty string")
(let ((alien-form (close-syntax alien-form usage-env))
- (sizeof (c-info `SIZEOF spec form usage-env))
+ (sizeof (c-info `sizeof spec form usage-env))
(index-form (close-syntax index-form usage-env))
- (proc (if bang? 'ALIEN-BYTE-INCREMENT! 'ALIEN-BYTE-INCREMENT)))
+ (proc (if bang? 'alien-byte-increment! 'alien-byte-increment)))
`(,proc ,alien-form (* ,sizeof ,index-form))))))))
(define (call-with-destructured-C-array-loc-form form receiver)
(cdr entry)
(swarn form "No declaration of callout"
func-name)))))
- `(CALL-ALIEN ,alien
+ `(call-alien ,alien
. ,(map (lambda (form) (close-syntax form usage-env))
arg-forms))))))))
(define (call-with-destructured-C-call-form form receiver)
- ;; Calls RECEIVER with the optional return-alien-form, func-name
+ ;; Calls receiver with the optional return-alien-form, func-name
;; (as a symbol), and the arg-forms.
(if (not (pair? (cdr form)))
(swarn form "No function name")
(if (pair? entry) (cdr entry)
(swarn form "No declaration of callback"))))
(let ((value-form (close-syntax obj usage-env)))
- `(REGISTER-C-CALLBACK ,value-form))))))))
+ `(register-c-callback ,value-form))))))))
(define (call-with-destructured-c-callback-form form receiver)
- ;; Calls RECEIVER with the only subform.
+ ;; Calls receiver with the only subform.
(let ((len (length form)))
(if (< len 2)
(swarn form "Too few args")
;;; Utilities
(define (find-c-includes env)
- ;; Returns the c-includes structure bound to 'C-INCLUDES in ENV.
+ ;; Returns the c-includes structure bound to 'C-includes in env.
(guarantee syntactic-environment? env 'find-c-includes)
(let ((ienv (senv->runtime env)))
- (if (and (environment-bound? ienv 'C-INCLUDES)
- (environment-assigned? ienv 'C-INCLUDES))
- (let ((includes (environment-lookup ienv 'C-INCLUDES)))
+ (if (and (environment-bound? ienv 'C-includes)
+ (environment-assigned? ienv 'C-includes))
+ (let ((includes (environment-lookup ienv 'C-includes)))
(if (c-includes? includes)
includes
(error "C-includes is not bound to a c-includes structure:"
(make-condition-type
'ffi-syntaxer-error
condition-type:error
- '(FORM MESSAGE)
+ '(form message)
(lambda (condition port)
(write-string "FFI syntax error: " port)
- (write-string (access-condition condition 'MESSAGE) port)
+ (write-string (access-condition condition 'message) port)
(write-string " in: " port)
- (write (access-condition condition 'FORM) port)
+ (write (access-condition condition 'form) port)
(write-char #\. port))))
(define serror
- (let ((signaller (condition-signaller condition-type:serror '(FORM MESSAGE)
+ (let ((signaller (condition-signaller condition-type:serror '(form message)
standard-error-handler)))
(named-lambda (serror form message . args)
(signaller form
(cons message args)))))))
(define (swarn form message . args)
- (apply warn message (append args (list 'IN form)))
+ (apply warn message (append args (list 'in form)))
`(error "Invalid syntax" ',form))
\ No newline at end of file
(let ((filename.db "gdbm-check.db"))
(ignore-errors (lambda () (delete-file filename.db)))
- (let ((dbf (gdbm-open filename.db 0 GDBM_WRCREAT #o660)))
+ (let ((dbf (gdbm-open filename.db 0 gdbm_wrcreat #o660)))
;; Must be set before first store.
- (gdbm-setopt dbf GDBM_CACHESIZE 101)
+ (gdbm-setopt dbf 'cachesize 101)
- (gdbm-store dbf "Silly String" "Testing 1 2 3." GDBM_REPLACE)
+ (gdbm-store dbf "Silly String" "Testing 1 2 3." gdbm_replace)
(if (not (condition?
(ignore-errors
- (lambda () (gdbm-store dbf "NullString" "" GDBM_INSERT)))))
+ (lambda () (gdbm-store dbf "NullString" "" gdbm_insert)))))
(error "storing null content did not signal"))
(if (not (condition?
(ignore-errors
- (lambda () (gdbm-store dbf "" "NullString" GDBM_INSERT)))))
+ (lambda () (gdbm-store dbf "" "NullString" gdbm_insert)))))
(error "storing null key did not signal"))
- (if (not (eq? #t (gdbm-store dbf "Silly String" "Ahoy!" GDBM_REPLACE)))
+ (if (not (eq? #t (gdbm-store dbf "Silly String" "Ahoy!" gdbm_replace)))
(error "replace produced wrong indication"))
- (if (not (eq? #f (gdbm-store dbf "Silly String" "Oy!" GDBM_INSERT)))
+ (if (not (eq? #f (gdbm-store dbf "Silly String" "Oy!" gdbm_insert)))
(error "double insert produced no indication"))
- (gdbm-setopt dbf GDBM_SYNCMODE 1)
+ (gdbm-setopt dbf 'syncmode 1)
(let ((content (gdbm-fetch dbf "Silly String")))
(if (not (string=? "Ahoy!" content))
(let ((k (gdbm-firstkey dbf)))
(if k
(error "empty database returned a firstkey:" k)))
- (gdbm-store dbf "AString" "Testing 1 2 3." GDBM_INSERT)
- (gdbm-store dbf "ASecondString" "Testing 1 2 3." GDBM_REPLACE)
- (gdbm-store dbf "AThirdString" "Testing 1 2 3." GDBM_INSERT)
+ (gdbm-store dbf "AString" "Testing 1 2 3." gdbm_insert)
+ (gdbm-store dbf "ASecondString" "Testing 1 2 3." gdbm_replace)
+ (gdbm-store dbf "AThirdString" "Testing 1 2 3." gdbm_insert)
#;
(let ((keys (sort (gdbm-keys dbf) string<?)))
(if (not (equal? keys '("ASecondString" "AString" "AThirdString")))
(gdbm-reorganize dbf)
(gdbm-sync dbf)
- (gdbm-setopt dbf 'SYNCMODE #f)
+ (gdbm-setopt dbf 'syncmode #f)
(gdbm-version)
(gdbm-close dbf))
(if (not (condition?
(ignore-errors
- (lambda () (gdbm-open "notfound.db" 0 GDBM_READER 0)))))
+ (lambda () (gdbm-open "notfound.db" 0 gdbm_reader 0)))))
(error "opened a nonexistent database file:" gdbf))
- (let ((dbf2 (gdbm-open filename.db 0 GDBM_READER 0)))
+ (let ((dbf2 (gdbm-open filename.db 0 gdbm_reader 0)))
(let ((keys (sort (gdbm-keys dbf2) string<?)))
(if (not (equal? keys '("ASecondString" "AString" "AThirdString")))
(error "bogus keys:" keys))
set -e
${MIT_SCHEME_EXE} --prepend-library . <<\EOF
-(load-option 'GDBM)
+(load-option 'gdbm)
(load "gdbm-check" (->environment '(gdbm)))
EOF
|#
-;;;; The GDBM option.
+;;;; The gdbm option.
;;; package: (gdbm)
(declare (usual-integrations))
(bytevector-length bytes)
(string-length bytes)))
-;; Parameters to gdbm_open for READERS, WRITERS, and WRITERS who can
+;; Parameters to gdbm_open for readers, writers, and writers who can
;; create the database.
-(define GDBM_READER (C-enum "GDBM_READER")) ;A reader.
-(define GDBM_WRITER (C-enum "GDBM_WRITER")) ;A writer.
-(define GDBM_WRCREAT(C-enum "GDBM_WRCREAT")) ;A writer. Create the db if needed.
-(define GDBM_NEWDB (C-enum "GDBM_NEWDB")) ;A writer. Always create a new db.
-(define GDBM_FAST (C-enum "GDBM_FAST")) ;Write fast! => No fsyncs.
+(define gdbm_reader (C-enum "GDBM_READER")) ;A reader.
+(define gdbm_writer (C-enum "GDBM_WRITER")) ;A writer.
+(define gdbm_wrcreat (C-enum "GDBM_WRCREAT")) ;A writer. Create the db if needed.
+(define gdbm_newdb (C-enum "GDBM_NEWDB")) ;A writer. Always create a new db.
+(define gdbm_fast (C-enum "GDBM_FAST")) ;Write fast! => No fsyncs.
(define (gdbm-open filename block-size flags mode)
- (guarantee integer? block-size 'GDBM-OPEN)
- (guarantee integer? mode 'GDBM-OPEN)
+ (guarantee integer? block-size 'gdbm-open)
+ (guarantee integer? mode 'gdbm-open)
(let ((args (make-alien '|gdbm_args|))
(flagsnum (guarantee-gdbm-open-flags flags))
(filename (->namestring (merge-pathnames filename))))
(define (guarantee-gdbm-open-flags flags)
(define (flag->number flag)
(case flag
- ((READER) (C-enum "GDBM_READER"))
- ((WRITER) (C-enum "GDBM_WRITER"))
- ((WRCREAT) (C-enum "GDBM_WRCREAT"))
- ((NEWDB) (C-enum "GDBM_NEWDB"))
- ((FAST) (C-enum "GDBM_FAST"))
- (else (error:wrong-type-argument flags "gdbm-open flags" 'GDBM-OPEN))))
+ ((reader) (C-enum "GDBM_READER"))
+ ((writer) (C-enum "GDBM_WRITER"))
+ ((wrcreat) (C-enum "GDBM_WRCREAT"))
+ ((newdb) (C-enum "GDBM_NEWDB"))
+ ((fast) (C-enum "GDBM_FAST"))
+ (else (error:wrong-type-argument flags "gdbm-open flags" 'gdbm-open))))
(cond ((integer? flags) flags)
((symbol? flags) (flag->number flags))
((list-of-type? flags symbol?)
(reduce + 0 (map flag->number flags)))
- (else (error:wrong-type-argument flags "gdbm-open flags" 'GDBM-OPEN))))
+ (else (error:wrong-type-argument flags "gdbm-open flags" 'gdbm-open))))
(define (gdbm-close gdbf)
- (guarantee-gdbf gdbf 'GDBM-CLOSE)
+ (guarantee-gdbf gdbf 'gdbm-close)
(with-gdbf-locked
gdbf
(lambda ()
;; Parameters to gdbm_store for simple insertion or replacement in the
;; case that the key is already in the database.
-(define GDBM_INSERT (C-enum "GDBM_INSERT")) ;Never replace old data.
-(define GDBM_REPLACE (C-enum "GDBM_REPLACE")) ;Always replace old data.
+(define gdbm_insert (C-enum "GDBM_INSERT")) ;Never replace old data.
+(define gdbm_replace (C-enum "GDBM_REPLACE")) ;Always replace old data.
(define (gdbm-store gdbf key content flag)
- (guarantee-gdbf gdbf 'GDBM-STORE)
- (guarantee-nonnull-string key 'GDBM-STORE)
- (guarantee-nonnull-string content 'GDBM-STORE)
- (let ((flagnum (cond ((= flag GDBM_INSERT) flag)
- ((= flag GDBM_REPLACE) flag)
- ((eq? flag 'INSERT) (C-enum "GDBM_INSERT"))
- ((eq? flag 'REPLACE) (C-enum "GDBM_REPLACE"))
+ (guarantee-gdbf gdbf 'gdbm-store)
+ (guarantee-nonnull-string key 'gdbm-store)
+ (guarantee-nonnull-string content 'gdbm-store)
+ (let ((flagnum (cond ((= flag gdbm_insert) flag)
+ ((= flag gdbm_replace) flag)
+ ((eq? flag 'insert) (C-enum "GDBM_INSERT"))
+ ((eq? flag 'replace) (C-enum "GDBM_REPLACE"))
(else (error:wrong-type-argument flag "gdbm-store flag"
- 'GDBM-STORE)))))
+ 'gdbm-store)))))
(with-gdbf-locked-open
- gdbf 'GDBM-STORE
+ gdbf 'gdbm-store
(lambda (args)
(gdbf-args-put-key! args key)
(gdbf-args-put-content! args content)
(else (gdbm-error gdbf "gdbm_store"))))))))
(define (gdbm-fetch gdbf key)
- (guarantee-gdbf gdbf 'GDBM-FETCH)
- (guarantee-nonnull-string key 'GDBM-FETCH)
+ (guarantee-gdbf gdbf 'gdbm-fetch)
+ (guarantee-nonnull-string key 'gdbm-fetch)
(with-gdbf-locked-open
- gdbf 'GDBM-FETCH
+ gdbf 'gdbm-fetch
(lambda (args)
(gdbf-args-put-key! args key)
(C-call "do_gdbm_fetch" args)
(gdbf-args-get-content args))))
(define (gdbm-exists? gdbf key)
- (guarantee-gdbf gdbf 'GDBM-EXISTS?)
- (guarantee-nonnull-string key 'GDBM-EXISTS?)
+ (guarantee-gdbf gdbf 'gdbm-exists?)
+ (guarantee-nonnull-string key 'gdbm-exists?)
(with-gdbf-locked-open
- gdbf 'GDBM-EXISTS
+ gdbf 'gdbm-exists
(lambda (args)
(gdbf-args-put-key! args key)
(not (zero? (C-call "do_gdbm_exists" args))))))
(define (gdbm-delete gdbf key)
- (guarantee-gdbf gdbf 'GDBM-DELETE)
- (guarantee-nonnull-string key 'GDBM-DELETE)
+ (guarantee-gdbf gdbf 'gdbm-delete)
+ (guarantee-nonnull-string key 'gdbm-delete)
(with-gdbf-locked-open
- gdbf 'GDBM-DELETE
+ gdbf 'gdbm-delete
(lambda (args)
(gdbf-args-put-key! args key)
(zero? (C-call "do_gdbm_delete" (gdbf-args gdbf))))))
(define (gdbm-keys gdbf)
- (guarantee-gdbf gdbf 'GDBM-KEYS)
+ (guarantee-gdbf gdbf 'gdbm-keys)
(with-gdbf-locked-open
- gdbf 'GDBM-KEYS
+ gdbf 'gdbm-keys
(lambda (args)
(C-call "do_gdbm_firstkey" args)
(let ((key (gdbf-args-get-key args)))
keys)))))))
(define (gdbm-firstkey gdbf)
- (guarantee-gdbf gdbf 'GDBM-FIRSTKEY)
+ (guarantee-gdbf gdbf 'gdbm-firstkey)
(with-gdbf-locked-open
- gdbf 'GDBM-FIRSTKEY
+ gdbf 'gdbm-firstkey
(lambda (args)
(C-call "do_gdbm_firstkey" args)
(gdbf-args-get-key args))))
(define (gdbm-nextkey gdbf key)
- ;; Returns #f if KEY is not (or no longer) in the database. Use
+ ;; Returns #f if key is not (or no longer) in the database. Use
;; gdbm-keys to read a complete list despite deletes. Gdbm-keys
;; also avoids copying the keys back for gdbm_nextkey.
- (guarantee-gdbf gdbf 'GDBM-NEXTKEY)
- (guarantee-nonnull-string key 'GDBM-NEXTKEY)
+ (guarantee-gdbf gdbf 'gdbm-nextkey)
+ (guarantee-nonnull-string key 'gdbm-nextkey)
(with-gdbf-locked-open
- gdbf 'GDBM-NEXTKEY
+ gdbf 'gdbm-nextkey
(lambda (args)
(gdbf-args-put-key! args key)
(if (zero? (C-call "do_gdbm_nextkey" args))
#f))))
(define (gdbm-reorganize gdbf)
- (guarantee-gdbf gdbf 'GDBM-REORGANIZE)
+ (guarantee-gdbf gdbf 'gdbm-reorganize)
(with-gdbf-locked-open
- gdbf 'GDBM-REORGANIZE
+ gdbf 'gdbm-reorganize
(lambda (args)
(if (not (zero? (C-call "do_gdbm_reorganize" args)))
(gdbm-error gdbf "gdbm_reorganize")))))
(define (gdbm-sync gdbf)
- (guarantee-gdbf gdbf 'GDBM-SYNC)
+ (guarantee-gdbf gdbf 'gdbm-sync)
(with-gdbf-locked-open
- gdbf 'GDBM-SYNC
+ gdbf 'gdbm-sync
(lambda (args)
(C-call "do_gdbm_sync" args))))
(define (gdbm-strerror errno)
- (guarantee fixnum? errno 'GDBM-STRERROR)
+ (guarantee fixnum? errno 'gdbm-strerror)
(c-peek-cstring (C-call "gdbm_strerror" (make-alien '(* char)) errno)))
(define (strerror errno)
- (guarantee fixnum? errno 'STRERROR)
+ (guarantee fixnum? errno 'strerror)
(c-peek-cstring (C-call "strerror" (make-alien '(* char)) errno)))
;; Parameters to gdbm_setopt, specifing the type of operation to perform.
-(define GDBM_CACHESIZE (C-enum "GDBM_CACHESIZE")) ;Set the cache size.
-(define GDBM_SYNCMODE (C-enum "GDBM_SYNCMODE")) ;Toggle fast mode.
+(define gdbm_cachesize (C-enum "GDBM_CACHESIZE")) ;Set the cache size.
+(define gdbm_syncmode (C-enum "GDBM_SYNCMODE")) ;Toggle fast mode.
(define (gdbm-setopt gdbf opt val)
- (guarantee-gdbf gdbf 'GDBM-SETOPT)
+ (guarantee-gdbf gdbf 'gdbm-setopt)
(let* ((optnum
- (cond ((eq? opt 'SYNCMODE) (C-enum "GDBM_SYNCMODE"))
- ((eq? opt 'CACHESIZE) (C-enum "GDBM_CACHESIZE"))
- ((and (number? opt) (= opt GDBM_SYNCMODE)) opt)
- ((and (number? opt) (= opt GDBM_CACHESIZE)) opt)
- (else (error:wrong-type-argument opt "option" 'GDBM-SETOPT))))
+ (cond ((eq? opt 'syncmode) (C-enum "GDBM_SYNCMODE"))
+ ((eq? opt 'cachesize) (C-enum "GDBM_CACHESIZE"))
+ ((and (number? opt) (= opt gdbm_syncmode)) opt)
+ ((and (number? opt) (= opt gdbm_cachesize)) opt)
+ (else (error:wrong-type-argument opt "option" 'gdbm-setopt))))
(valnum
- (cond ((= optnum GDBM_SYNCMODE)
- (cond ((not val) 0)
+ (cond ((= optnum gdbm_syncmode)
+ (cond ((eq? val #f) 0)
((eq? val #t) 1)
((zero? val) val)
((= val 1) val)
- (else (error:wrong-type-argument val "SYNCMODE boolean"
- 'GDBM-SETOPT))))
- ((= optnum GDBM_CACHESIZE)
- (guarantee integer? val 'GDBM-SETOPT)
+ (else (error:wrong-type-argument val "syncmode"
+ 'gdbm-setopt))))
+ ((= optnum gdbm_cachesize)
+ (guarantee integer? val 'gdbm-setopt)
val))))
(with-gdbf-locked-open
- gdbf 'GDBM-SETOPT
+ gdbf 'gdbm-setopt
(lambda (args)
(if (not (zero? (C-call "do_gdbm_setopt" args optnum valnum)))
(gdbm-error gdbf "gdbm_setopt"))))))
\f
(define-structure (gdbf (constructor make-gdbf)
(print-procedure
- (standard-print-method 'GDBF
+ (standard-print-method 'gdbf
(lambda (gdbf)
(list (gdbf-filename gdbf))))))
;; Note that communicating through this malloced-per-GDBM_FILE
#| -*-Scheme-*- |#
-(define-load-option 'GDBM
+(define-load-option 'gdbm
(standard-system-loader "."))
(further-load-options #t)
\ No newline at end of file
(loop scms chs cdecls (cons section rest))))))))))
(parameterize ((param:suppress-loading-message? #t))
- (load-option 'FFI))
+ (load-option 'ffi))
((access rewrite-file (->environment '(ffi build)))
(merge-pathnames "TAGS")
rewriter)))
To use the plugin:
- (load-option 'GL)
+ (load-option 'gl)
(make-glxgears-demo)
To import the plugin's bindings into a CREF package set (.pkg file):
;;;; Run the GLXGears demo.
-(load-option 'CREF)
-(load-option 'SOS)
-(load-option 'FFI)
-(load-option 'GTK)
+(for-each load-option '(cref sos ffi gtk))
(if (gtk-initialized?)
(begin
(begin
(parameterize ((param:suppress-loading-message? #t))
- (load-option 'CREF)
- (load-option 'GTK)
- (load-option 'FFI))
+ (load-option 'cref)
+ (load-option 'gtk)
+ (load-option 'ffi))
- (if (name->package '(GL))
- (error "The GL package already exists."))
+ (if (name->package '(gl))
+ (error "The gl package already exists."))
(let ((package-set (package-set-pathname "gl")))
(if (not (file-modification-time<? "gl.pkg" package-set))
(cref/generate-trivial-constructor "gl"))
: ${MIT_SCHEME_EXE=mit-scheme}
${MIT_SCHEME_EXE} --prepend-library . <<\EOF
(begin
- (load-option 'GL)
- (let ((new (extend-top-level-environment (->environment '(GL))))
- (ffi (->environment '(RUNTIME FFI))))
+ (load-option 'gl)
+ (let ((new (extend-top-level-environment (->environment '(gl))))
+ (ffi (->environment '(runtime ffi))))
(load "gl-tests" new)
(if (gtk-initialized?)
(let ((await-closed-demo (access await-closed-demo new))
(assert-clean-ffi (access assert-clean-ffi new)))
(with-gc-notification! #t await-closed-demo)
(assert-clean-ffi "gtk"))
- (warn "Could not test the GTK subsystem without a DISPLAY.")))
+ (warn "Could not test the Gtk subsystem without a DISPLAY.")))
)
EOF
(define-syntax error-if-null
(syntax-rules ()
- ((_ ALIEN MESSAGE ...)
- (if (alien-null? ALIEN)
- (error MESSAGE ...)))))
+ ((_ alien message ...)
+ (if (alien-null? alien)
+ (error message ...)))))
(define (with-glx-widget widget thunk)
(let ((xdisplay (glx-widget-xdisplay widget))
(let ((aspect (->flonum (/ w h))))
(with-glx-widget widget
(lambda ()
- (gl:matrix-mode 'PROJECTION)
+ (gl:matrix-mode 'projection)
(gl:load-identity)
(gl:viewport 0 0 w h)
(glu:perspective (glx-viewport-fovy widget)
"\n")
(with-glx-widget widget
(lambda ()
- (gl:matrix-mode 'MODELVIEW)
+ (gl:matrix-mode 'modelview)
(gl:load-identity)
(let ((position (glx-viewport-position widget))
;; Heading 0. is N: ( 0. 0. -1.)
cos-tilt
(flo:* sin-tilt -cos-heading))))
(glu:look-at position center up))))
- (gl:clear 'COLOR-BUFFER 'DEPTH-BUFFER)
+ (gl:clear 'color-buffer 'depth-buffer)
(glx-viewport-draw widget)
(glx:swap-buffers widget)
#t)))
(define-syntax %trace
(syntax-rules ()
- ((_ ARGS ...)
- (if %trace? (outf-error ARGS ...)))))
\ No newline at end of file
+ ((_ args ...)
+ (if %trace? (outf-error args ...)))))
\ No newline at end of file
(%trace "visibility-notify-handler "widget" "how)
(let ((old (glxgears-demo-visibility widget)))
(set-glxgears-demo-visibility! widget how)
- (if (and (eq? old 'OBSCURED) (not (eq? how 'OBSCURED)))
+ (if (and (eq? old 'obscured) (not (eq? how 'obscured)))
(wake-animation-thread widget)))
#t)
(let ((visibility (glxgears-demo-visibility widget)))
(if (or (not (glx-widget-realized? widget))
(not (glxgears-demo-animate? widget))
- (eq? 'OBSCURED visibility))
+ (eq? 'obscured visibility))
(begin
- (if (and %trace? (eq? 'OBSCURED visibility))
+ (if (and %trace? (eq? 'obscured visibility))
(%trace2
"animation sleeping while obscured...")
(%trace2 "animation sleeping..."))
(if (and (glx-widget-realized? widget)
(glxgears-demo-animate? widget)
- (not (eq? 'OBSCURED
+ (not (eq? 'obscured
(glxgears-demo-visibility widget))))
(draw-frame widget)
(%trace2 "animation skip!"))
(define (draw-gears angle gear1 gear2 gear3 view-rotx view-roty)
(%trace2 " draw-gears "
angle" "gear1" "gear2" "gear3" "view-rotx" "view-roty)
- (gl:clear 'COLOR-BUFFER 'DEPTH-BUFFER)
+ (gl:clear 'color-buffer 'depth-buffer)
(gl:push-matrix)
(gl:rotate view-rotx 1. 0. 0.)
(gl:rotate view-roty 0. 1. 0.)
(%trace " reshape "width" "height" "widget)
(gl:viewport 0 0 width height)
(let ((h (/ (->flonum height) (->flonum width))))
- (gl:matrix-mode 'PROJECTION)
+ (gl:matrix-mode 'projection)
(gl:load-identity)
(gl:frustum -1. 1. (- h) h 5. 60.))
- (gl:matrix-mode 'MODELVIEW)
+ (gl:matrix-mode 'modelview)
(gl:load-identity)
(gl:translate 0. 0. -40.)
(set-glxgears-demo-frame-start! widget #f)
(green (color 0.0 0.8 0.2 1.0))
(blue (color 0.2 0.2 1.0 1.0)))
(%trace "light")
- (gl:light 'LIGHT0 'POSITION pos)
- (gl:enable 'CULL-FACE)
- (gl:enable 'LIGHTING)
- (gl:enable 'LIGHT0)
- (gl:enable 'DEPTH-TEST)
+ (gl:light 'light0 'position pos)
+ (gl:enable 'cull-face)
+ (gl:enable 'lighting)
+ (gl:enable 'light0)
+ (gl:enable 'depth-test)
;; make the gears
(let ((gear1 (gl:gen-lists 1)))
(%trace "gear1 = "gear1)
- (gl:new-list gear1 'COMPILE)
- (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE red)
+ (gl:new-list gear1 'compile)
+ (gl:material 'front 'ambient-and-diffuse red)
(draw-gear 1.0 4.0 1.0 20. 0.7)
(gl:end-list)
(let ((gear2 (gl:gen-lists 1)))
(%trace "gear2 = "gear2)
- (gl:new-list gear2 'COMPILE)
- (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE green)
+ (gl:new-list gear2 'compile)
+ (gl:material 'front 'ambient-and-diffuse green)
(draw-gear 0.5 2.0 2.0 10. 0.7)
(gl:end-list)
(let ((gear3 (gl:gen-lists 1)))
(%trace "gear3 = "gear3)
- (gl:new-list gear3 'COMPILE)
- (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE blue)
+ (gl:new-list gear3 'compile)
+ (gl:material 'front 'ambient-and-diffuse blue)
(draw-gear 1.3 2.0 0.5 10. 0.7)
(gl:end-list)
- (gl:enable 'NORMALIZE)
+ (gl:enable 'normalize)
(set-glxgears-demo-gears! widget (list gear1 gear2 gear3)))))))
(define (draw-gear inner-radius ; radius of hole at center
(let ((2da (* 2. da))
(3da (* 3. da)))
- (gl:shade-model 'FLAT)
+ (gl:shade-model 'flat)
(gl:normal (flo:3d 0. 0. 1.))
;; draw front face
- (gl:begin 'QUAD-STRIP)
+ (gl:begin 'quad-strip)
(do ((i 0. (+ i 1.)))
((> i teeth))
(let ((angle (* i 2pi/teeth)))
(gl:end)
;; draw front sides of teeth
- (gl:begin 'QUADS)
+ (gl:begin 'quads)
(do ((i 0. (+ i 1.)))
((= i teeth))
(let ((angle (* i 2pi/teeth)))
(gl:normal (flo:3d 0. 0. -1.))
;; draw back face
- (gl:begin 'QUAD-STRIP)
+ (gl:begin 'quad-strip)
(do ((i 0. (+ i 1.)))
((> i teeth))
(let ((angle (* i 2pi/teeth)))
(gl:end)
;; draw back sides of teeth
- (gl:begin 'QUADS)
+ (gl:begin 'quads)
(do ((i 0. (+ i 1.)))
((= i teeth))
(let ((angle (* i 2pi/teeth)))
(gl:end)
;; draw outward faces of teeth
- (gl:begin 'QUAD-STRIP)
+ (gl:begin 'quad-strip)
(do ((i 0. (+ i 1.)))
((= i teeth))
(let ((angle (* i 2pi/teeth)))
(gl:vertex3 (* r1 (cos 0.)) (* r1 (sin 0.)) -width/2)
(gl:end)
- (gl:shade-model 'SMOOTH)
+ (gl:shade-model 'smooth)
;; draw inside radius cylinder
- (gl:begin 'QUAD-STRIP)
+ (gl:begin 'quad-strip)
(do ((i 0. (+ i 1.)))
((> i teeth))
(let ((angle (* i 2pi/teeth)))
(define-syntax %trace
(syntax-rules ()
- ((_ ARGS ...)
- (if %trace? (outf-error "; glxgears: " ARGS ... "\n")))))
+ ((_ args ...)
+ (if %trace? (outf-error "; glxgears: " args ... "\n")))))
(define %trace2? #f)
(define-syntax %trace2
(syntax-rules ()
- ((_ ARGS ...)
- (if %trace2? (outf-error "; glxgears: " ARGS ... "\n")))))
\ No newline at end of file
+ ((_ args ...)
+ (if %trace2? (outf-error "; glxgears: " args ... "\n")))))
\ No newline at end of file
(C-include "gl")
(define (gl:shade-model model)
- (guarantee-current 'GL:SHADE-MODEL)
+ (guarantee-current 'gl:shade-model)
(C-call "glShadeModel"
(case model
- ((FLAT) (C-enum "GL_FLAT"))
- ((SMOOTH) (C-enum "GL_SMOOTH"))
+ ((flat) (C-enum "GL_FLAT"))
+ ((smooth) (C-enum "GL_SMOOTH"))
(else (error "gl:shade-model: Unknown model:" model)))))
(define (gl:clear-color color)
- (guarantee-current 'GL:CLEAR-COLOR)
+ (guarantee-current 'gl:clear-color)
(guarantee-color color 'gl:clear-color)
(C-call "gl_clear_color" color))
(define (gl:clear-depth depth)
- (guarantee-current 'GL:CLEAR-DEPTH)
- (guarantee-gl-depth depth 'GL:CLEAR-DEPTH)
+ (guarantee-current 'gl:clear-depth)
+ (guarantee-gl-depth depth 'gl:clear-depth)
(C-call "glClearDepth" depth))
(define (->capability cap operator)
(case cap
- ((DEPTH-TEST) (C-enum "GL_DEPTH_TEST"))
- ((CULL-FACE) (C-enum "GL_CULL_FACE"))
- ((LIGHT0) (C-enum "GL_LIGHT0"))
- ((LIGHT1) (C-enum "GL_LIGHT1"))
- ((LIGHT2) (C-enum "GL_LIGHT2"))
- ((LIGHT3) (C-enum "GL_LIGHT3"))
- ((LIGHT4) (C-enum "GL_LIGHT4"))
- ((LIGHT5) (C-enum "GL_LIGHT5"))
- ((LIGHT6) (C-enum "GL_LIGHT6"))
- ((LIGHT7) (C-enum "GL_LIGHT7"))
- ((LIGHTING) (C-enum "GL_LIGHTING"))
- ((NORMALIZE) (C-enum "GL_NORMALIZE"))
- ((RESCALE-NORMAL) (C-enum "GL_RESCALE_NORMAL"))
- ((COLOR-MATERIAL) (C-enum "GL_COLOR_MATERIAL"))
+ ((depth-test) (C-enum "GL_DEPTH_TEST"))
+ ((cull-face) (C-enum "GL_CULL_FACE"))
+ ((light0) (c-enum "GL_LIGHT0"))
+ ((light1) (C-enum "GL_LIGHT1"))
+ ((light2) (C-enum "GL_LIGHT2"))
+ ((light3) (C-enum "GL_LIGHT3"))
+ ((light4) (C-enum "GL_LIGHT4"))
+ ((light5) (C-enum "GL_LIGHT5"))
+ ((light6) (C-enum "GL_LIGHT6"))
+ ((light7) (C-enum "GL_LIGHT7"))
+ ((lighting) (C-enum "GL_LIGHTING"))
+ ((normalize) (C-enum "GL_NORMALIZE"))
+ ((rescale-normal) (C-enum "GL_RESCALE_NORMAL"))
+ ((color-material) (C-enum "GL_COLOR_MATERIAL"))
(else (error:wrong-type-argument cap "a GL capability" operator))))
(define (gl:enable capability)
- (guarantee-current 'GL:ENABLE)
- (C-call "glEnable" (->capability capability 'GL:ENABLE)))
+ (guarantee-current 'gl:enable)
+ (C-call "glEnable" (->capability capability 'gl:enable)))
(define (gl:disable capability)
- (guarantee-current 'GL:DISABLE)
- (C-call "glDisable" (->capability capability 'GL:DISABLE)))
+ (guarantee-current 'gl:disable)
+ (C-call "glDisable" (->capability capability 'gl:disable)))
(define (gl:depth-func function)
- (guarantee-current 'GL:DEPTH-FUNC)
+ (guarantee-current 'gl:depth-func)
(C-call "glDepthFunc"
(case function
- ((LEQUAL) (C-enum "GL_LEQUAL"))
+ ((lequal) (C-enum "GL_LEQUAL"))
(else (error "Unknown glDepthFunc function:" function)))))
(define (gl:blend-func sfactor dfactor)
- (guarantee-current 'GL:BLEND-FUNC)
- (let ((s (->blend-factor sfactor 'GL:BLEND-FUNC))
- (d (->blend-factor dfactor 'GL:BLEND-FUNC)))
+ (guarantee-current 'gl:blend-func)
+ (let ((s (->blend-factor sfactor 'gl:blend-func))
+ (d (->blend-factor dfactor 'gl:blend-func)))
(C-call "glBlendFunc" s d)))
(define (->blend-factor f op)
(case f
- ((ZERO) (C-enum "GL_ZERO"))
- ((ONE) (C-enum "GL_ONE"))
- ((SRC-COLOR) (C-enum "GL_SRC_COLOR"))
- ((ONE-MINUS-SRC-COLOR) (C-enum "GL_ONE_MINUS_SRC_COLOR"))
- ((DST-COLOR) (C-enum "GL_DST_COLOR"))
- ((ONE-MINUS-DST-COLOR) (C-enum "GL_ONE_MINUS_DST_COLOR"))
- ((SRC-ALPHA) (C-enum "GL_SRC_ALPHA"))
- ((ONE-MINUS-SRC-ALPHA) (C-enum "GL_ONE_MINUS_SRC_ALPHA"))
- ((DST-ALPHA) (C-enum "GL_DST_ALPHA"))
- ((ONE-MINUS-DST-ALPHA) (C-enum "GL_ONE_MINUS_DST_ALPHA"))
- ((CONSTANT-COLOR) (C-enum "GL_CONSTANT_COLOR"))
- ((ONE-MINUS-CONSTANT-COLOR) (C-enum "GL_ONE_MINUS_CONSTANT_COLOR"))
- ((CONSTANT-ALPHA) (C-enum "GL_CONSTANT_ALPHA"))
- ((ONE-MINUS-CONSTANT-ALPHA) (C-enum "GL_ONE_MINUS_CONSTANT_ALPHA"))
- ((SRC-ALPHA-SATURATE) (C-enum "GL_SRC_ALPHA_SATURATE"))
+ ((zero) (C-enum "GL_ZERO"))
+ ((one) (C-enum "GL_ONE"))
+ ((src-color) (C-enum "GL_SRC_COLOR"))
+ ((one-minus-src-color) (C-enum "GL_ONE_MINUS_SRC_COLOR"))
+ ((dst-color) (C-enum "GL_DST_COLOR"))
+ ((one-minus-dst-color) (C-enum "GL_ONE_MINUS_DST_COLOR"))
+ ((src-alpha) (C-enum "GL_SRC_ALPHA"))
+ ((one-minus-src-alpha) (C-enum "GL_ONE_MINUS_SRC_ALPHA"))
+ ((dst-alpha) (C-enum "GL_DST_ALPHA"))
+ ((one-minus-dst-alpha) (C-enum "GL_ONE_MINUS_DST_ALPHA"))
+ ((constant-color) (C-enum "GL_CONSTANT_COLOR"))
+ ((one-minus-constant-color) (C-enum "GL_ONE_MINUS_CONSTANT_COLOR"))
+ ((constant-alpha) (C-enum "GL_CONSTANT_ALPHA"))
+ ((one-minus-constant-alpha) (C-enum "GL_ONE_MINUS_CONSTANT_ALPHA"))
+ ((src-alpha-saturate) (C-enum "GL_SRC_ALPHA_SATURATE"))
(else (error:wrong-type-argument f "GL blend factor" op))))
(define (gl:cull-face mode)
- (guarantee-current 'GL:CULL-FACE)
+ (guarantee-current 'gl:cull-face)
(C-call "glCullFace"
(case mode
- ((FRONT) (C-enum "GL_FRONT"))
- ((BACK) (C-enum "GL_BACK"))
- ((FRONT-AND-BACK) (C-enum "GL_FRONT_AND_BACK"))
+ ((front) (C-enum "GL_FRONT"))
+ ((back) (C-enum "GL_BACK"))
+ ((front-and-back) (C-enum "GL_FRONT_AND_BACK"))
(else (error "Unknown glCullFace mode:" mode)))))
(define (gl:hint target mode)
- (guarantee-current 'GL:HINT)
+ (guarantee-current 'gl:hint)
(C-call "glHint"
(case target
- ((PERSPECTIVE-CORRECTION) (C-enum "GL_PERSPECTIVE_CORRECTION_HINT"))
+ ((perspective-correction) (C-enum "GL_PERSPECTIVE_CORRECTION_HINT"))
(else (error "Unknown glHint target:" target)))
(case mode
- ((NICEST) (C-enum "GL_NICEST"))
+ ((nicest) (C-enum "GL_NICEST"))
(else (error "Unknown glHint mode:" mode)))))
(define (gl:color-material face mode)
(C-call "glColorMaterial"
(case face
- ((FRONT) (C-enum "GL_FRONT"))
- ((FRONT-AND-BACK) (C-enum "GL_FRONT_AND_BACK"))
- ((BACK) (C-enum "GL_BACK"))
+ ((front) (C-enum "GL_FRONT"))
+ ((front-and-back) (C-enum "GL_FRONT_AND_BACK"))
+ ((back) (C-enum "GL_BACK"))
(else (error "Unknown glColorMaterial face:" face)))
(case mode
- ((EMISSION) (C-enum "GL_EMISSION"))
- ((AMBIENT) (C-enum "GL_AMBIENT"))
- ((DIFFUSE) (C-enum "GL_DIFFUSE"))
- ((SPECULAR) (C-enum "GL_SPECULAR"))
- ((AMBIENT-AND-DIFFUSE) (C-enum "GL_AMBIENT_AND_DIFFUSE"))
+ ((emission) (C-enum "GL_EMISSION"))
+ ((ambient) (C-enum "GL_AMBIENT"))
+ ((diffuse) (C-enum "GL_DIFFUSE"))
+ ((specular) (C-enum "GL_SPECULAR"))
+ ((ambient-and-diffuse) (C-enum "GL_AMBIENT_AND_DIFFUSE"))
(else (error "Unknown glColorMaterial mode:" mode)))))
(define (gl:clear . bits)
- (guarantee-current 'GL:CLEAR)
+ (guarantee-current 'gl:clear)
(C-call "glClear"
(reduce + 0 (map (lambda (bit)
(case bit
- ((COLOR-BUFFER)
+ ((color-buffer)
(C-enum "GL_COLOR_BUFFER_BIT"))
- ((DEPTH-BUFFER)
+ ((depth-buffer)
(C-enum "GL_DEPTH_BUFFER_BIT"))
- ((STENCIL-BUFFER)
+ ((stencil-buffer)
(C-enum "GL_STENCIL_BUFFER_BIT"))
(else (error "Unknwon glClear bit:" bit))))
bits))))
(define (gl:load-identity)
- (guarantee-current 'GL:LOAD-IDENTITY)
+ (guarantee-current 'gl:load-identity)
(C-call "glLoadIdentity"))
(define (gl:scale kx ky kz)
- (guarantee-current 'GL:SCALE)
- (guarantee flo:flonum? kx 'GL:SCALE)
- (guarantee flo:flonum? ky 'GL:SCALE)
- (guarantee flo:flonum? kz 'GL:SCALE)
+ (guarantee-current 'gl:scale)
+ (guarantee flo:flonum? kx 'gl:scale)
+ (guarantee flo:flonum? ky 'gl:scale)
+ (guarantee flo:flonum? kz 'gl:scale)
(C-call "glScaled" kx ky kz))
(define (gl:begin mode)
- (guarantee-current 'GL:BEGIN)
+ (guarantee-current 'gl:begin)
(C-call "glBegin"
(case mode
- ((POINTS) (C-enum "GL_POINTS"))
- ((LINES) (C-enum "GL_LINES"))
- ((LINE-LOOP) (C-enum "GL_LINE_LOOP"))
- ((LINE-STRIP) (C-enum "GL_LINE_STRIP"))
- ((TRIANGLES) (C-enum "GL_TRIANGLES"))
- ((TRIANGLE-STRIP) (C-enum "GL_TRIANGLE_STRIP"))
- ((TRIANGLE-FAN) (C-enum "GL_TRIANGLE_FAN"))
- ((QUADS) (C-enum "GL_QUADS"))
- ((QUAD-STRIP) (C-enum "GL_QUAD_STRIP"))
- ((POLYGON) (C-enum "GL_POLYGON"))
+ ((points) (C-enum "GL_POINTS"))
+ ((lines) (C-enum "GL_LINES"))
+ ((line-loop) (C-enum "GL_LINE_LOOP"))
+ ((line-strip) (C-enum "GL_LINE_STRIP"))
+ ((triangles) (C-enum "GL_TRIANGLES"))
+ ((triangle-strip) (C-enum "GL_TRIANGLE_STRIP"))
+ ((triangle-fan) (C-enum "GL_TRIANGLE_FAN"))
+ ((quads) (C-enum "GL_QUADS"))
+ ((quad-strip) (C-enum "GL_QUAD_STRIP"))
+ ((polygon) (C-enum "GL_POLYGON"))
(else (error "Unknown glBegin mode:" mode)))))
(define (gl:color color)
- (guarantee-current 'GL:COLOR)
- (guarantee-color color 'GL:COLOR)
+ (guarantee-current 'gl:color)
+ (guarantee-color color 'gl:color)
(C-call "glColor4dv" color))
(define (gl:vertex point)
- (guarantee-current 'GL:VERTEX)
- (guarantee-3d point 'GL:VERTEX)
+ (guarantee-current 'gl:vertex)
+ (guarantee-3d point 'gl:vertex)
(C-call "glVertex3dv" point))
(define (gl:end)
- (guarantee-current 'GL:END)
+ (guarantee-current 'gl:end)
(C-call "glEnd"))
(define (gl:call-list lst)
- (guarantee-current 'GL:CALL-LIST)
- (guarantee integer? lst 'GL:CALL-LIST)
+ (guarantee-current 'gl:call-list)
+ (guarantee integer? lst 'gl:call-list)
(C-call "glCallList" lst))
(define (gl:draw-buffer buffer)
- (guarantee-current 'GL:DRAW-BUFFER)
+ (guarantee-current 'gl:draw-buffer)
(C-call "glDrawBuffer"
(case buffer
- ((BACK-LEFT) (C-enum "GL_BACK_LEFT"))
- ((BACK-RIGHT) (C-enum "GL_BACK_RIGHT"))
+ ((back-left) (C-enum "GL_BACK_LEFT"))
+ ((back-right) (C-enum "GL_BACK_RIGHT"))
(else (error "gl:draw-buffer: Unknown buffer:" buffer)))))
(define (gl:frustum left right bottom top near-val far-val)
- (guarantee-current 'GL:DRAW-BUFFER)
- (guarantee flo:flonum? left 'GL:DRAW-BUFFER)
- (guarantee flo:flonum? right 'GL:DRAW-BUFFER)
- (guarantee flo:flonum? bottom 'GL:DRAW-BUFFER)
- (guarantee flo:flonum? top 'GL:DRAW-BUFFER)
- (guarantee flo:flonum? near-val 'GL:DRAW-BUFFER)
- (guarantee flo:flonum? far-val 'GL:DRAW-BUFFER)
+ (guarantee-current 'gl:draw-buffer)
+ (guarantee flo:flonum? left 'gl:draw-buffer)
+ (guarantee flo:flonum? right 'gl:draw-buffer)
+ (guarantee flo:flonum? bottom 'gl:draw-buffer)
+ (guarantee flo:flonum? top 'gl:draw-buffer)
+ (guarantee flo:flonum? near-val 'gl:draw-buffer)
+ (guarantee flo:flonum? far-val 'gl:draw-buffer)
(C-call "glFrustum" left right bottom top near-val far-val))
(define (gl:gen-lists range)
- (guarantee-current 'GL:GEN-LISTS)
- (guarantee integer? range 'GL:GEN-LISTS)
+ (guarantee-current 'gl:gen-lists)
+ (guarantee integer? range 'gl:gen-lists)
(C-call "glGenLists" range))
(define (gl:light light param values)
- (guarantee-current 'GL:LIGHT)
+ (guarantee-current 'gl:light)
(C-call "gl_light"
(case light
- ((LIGHT0) (C-enum "GL_LIGHT0"))
- ((LIGHT1) (C-enum "GL_LIGHT1"))
- ((LIGHT2) (C-enum "GL_LIGHT2"))
- ((LIGHT3) (C-enum "GL_LIGHT3"))
- ((LIGHT4) (C-enum "GL_LIGHT4"))
- ((LIGHT5) (C-enum "GL_LIGHT5"))
- ((LIGHT6) (C-enum "GL_LIGHT6"))
- ((LIGHT7) (C-enum "GL_LIGHT7"))
+ ((light0) (C-enum "GL_LIGHT0"))
+ ((light1) (C-enum "GL_LIGHT1"))
+ ((light2) (C-enum "GL_LIGHT2"))
+ ((light3) (C-enum "GL_LIGHT3"))
+ ((light4) (C-enum "GL_LIGHT4"))
+ ((light5) (C-enum "GL_LIGHT5"))
+ ((light6) (C-enum "GL_LIGHT6"))
+ ((light7) (C-enum "GL_LIGHT7"))
(else (error "gl:light: Unknown light:" light)))
(case param
- ((POSITION)
- (guarantee-4d values 'GL:LIGHT)
+ ((position)
+ (guarantee-4d values 'gl:light)
(C-enum "GL_POSITION"))
- ((AMBIENT)
- (guarantee-4d values 'GL:LIGHT)
+ ((ambient)
+ (guarantee-4d values 'gl:light)
(C-enum "GL_AMBIENT"))
- ((DIFFUSE)
- (guarantee-4d values 'GL:LIGHT)
+ ((diffuse)
+ (guarantee-4d values 'gl:light)
(C-enum "GL_DIFFUSE"))
- ((SPECULAR)
- (guarantee-4d values 'GL:LIGHT)
+ ((specular)
+ (guarantee-4d values 'gl:light)
(C-enum "GL_SPECULAR"))
(else (error "gl:light: Unknown parameter:" param)))
values))
(define (gl:light-model param value)
(case param
- ((LOCAL-VIEWER)
+ ((local-viewer)
(guarantee flo:flonum? value 'gl:light-model)
(C-call "glLightModelf" (C-enum "GL_LIGHT_MODEL_LOCAL_VIEWER") value))
- ((COLOR-CONTROL)
+ ((color-control)
(C-call "glLightModeli" (C-enum "GL_LIGHT_MODEL_COLOR_CONTROL")
(case value
- ((SEPARATE-SPECULAR-COLOR) (C-enum "GL_SEPARATE_SPECULAR_COLOR"))
- ((SINGLE-COLOR) (C-enum "GL_SINGLE_COLOR"))
+ ((separate-specular-color) (C-enum "GL_SEPARATE_SPECULAR_COLOR"))
+ ((single-color) (C-enum "GL_SINGLE_COLOR"))
(else (error "gl:light-model: Unknown color-control:" value)))))
- ((TWO-SIDE)
+ ((two-side)
(guarantee flo:flonum? value 'gl:light-model)
(C-call "glLightModelf" (C-enum "GL_LIGHT_MODEL_TWO_SIDE") value))
- ((AMBIENT)
+ ((ambient)
(guarantee-4d value 'gl:light-model)
(C-call "gl_light_model_v" (C-enum "GL_LIGHT_MODEL_AMBIENT") value))
(else
(error "gl:light-model: Unknown parameter:" param))))
(define (gl:material face param values)
- (guarantee-current 'GL:MATERIAL)
+ (guarantee-current 'gl:material)
(C-call "gl_material"
(case face
- ((FRONT) (C-enum "GL_FRONT"))
- ((BACK) (C-enum "GL_BACK"))
- ((FRONT-AND-BACK) (C-enum "GL_FRONT_AND_BACK"))
+ ((front) (C-enum "GL_FRONT"))
+ ((back) (C-enum "GL_BACK"))
+ ((front-and-back) (C-enum "GL_FRONT_AND_BACK"))
(else (error "gl:material: Unknown face:" face)))
(case param
- ((AMBIENT)
- (guarantee-4d values 'GL:MATERIAL)
+ ((ambient)
+ (guarantee-4d values 'gl:material)
(C-enum "GL_AMBIENT"))
- ((DIFFUSE)
- (guarantee-4d values 'GL:MATERIAL)
+ ((diffuse)
+ (guarantee-4d values 'gl:material)
(C-enum "GL_DIFFUSE"))
- ((SPECULAR)
- (guarantee-4d values 'GL:MATERIAL)
+ ((specular)
+ (guarantee-4d values 'gl:material)
(C-enum "GL_SPECULAR"))
- ((EMISSION)
- (guarantee-4d values 'GL:MATERIAL)
+ ((emission)
+ (guarantee-4d values 'gl:material)
(C-enum "GL_EMISSION"))
- ((SHININESS)
- (guarantee flo:flonum? values 'GL:MATERIAL)
+ ((shininess)
+ (guarantee flo:flonum? values 'gl:material)
(C-enum "GL_SHININESS"))
- ((AMBIENT-AND-DIFFUSE)
- (guarantee-4d values 'GL:MATERIAL)
+ ((ambient-and-diffuse)
+ (guarantee-4d values 'gl:material)
(C-enum "GL_AMBIENT_AND_DIFFUSE"))
- ((COLOR-INDEXES)
- (guarantee-3d values 'GL:MATERIAL)
+ ((color-indexes)
+ (guarantee-3d values 'gl:material)
(C-enum "GL_COLOR_INDEXES"))
(else (error "gl:material: Unknown parameter:" param)))
values))
(define (gl:matrix-mode mode)
- (guarantee-current 'GL:MATRIX-MODE)
+ (guarantee-current 'gl:matrix-mode)
(C-call "glMatrixMode"
(case mode
- ((MODELVIEW) (C-enum "GL_MODELVIEW"))
- ((PROJECTION) (C-enum "GL_PROJECTION"))
+ ((modelview) (C-enum "GL_MODELVIEW"))
+ ((projection) (C-enum "GL_PROJECTION"))
(else (error "gl:matrix-mode: Unknown mode:" mode)))))
(define (gl:new-list lst mode)
- (guarantee-current 'GL:NEW-LIST)
- (guarantee integer? lst 'GL:NEW-LIST)
+ (guarantee-current 'gl:new-list)
+ (guarantee integer? lst 'gl:new-list)
(C-call "glNewList"
lst
(case mode
- ((COMPILE) (C-enum "GL_COMPILE"))
+ ((compile) (C-enum "GL_COMPILE"))
(else (error "gl:new-list: Unknown mode:" mode)))))
(define (gl:end-list)
(C-call "glEndList"))
(define (gl:delete-lists lst range)
- (guarantee-current 'GL:DELETE-LISTS)
- (guarantee integer? lst 'GL:DELETE-LISTS)
- (guarantee integer? range 'GL:DELETE-LISTS)
+ (guarantee-current 'gl:delete-lists)
+ (guarantee integer? lst 'gl:delete-lists)
+ (guarantee integer? range 'gl:delete-lists)
(C-call "glDeleteLists" lst range))
(define (gl:normal 3d)
- (guarantee-current 'GL:NORMAL)
- (guarantee-3d 3d 'GL:NORMAL)
+ (guarantee-current 'gl:normal)
+ (guarantee-3d 3d 'gl:normal)
(C-call "glNormal3dv" 3d))
(define (gl:pop-matrix)
- (guarantee-current 'GL:POP-MATRIX)
+ (guarantee-current 'gl:pop-matrix)
(C-call "glPopMatrix"))
(define (gl:push-matrix)
- (guarantee-current 'GL:PUSH-MATRIX)
+ (guarantee-current 'gl:push-matrix)
(C-call "glPushMatrix"))
(define (gl:rotate angle x y z)
- (guarantee-current 'GL:ROTATE)
- (guarantee flo:flonum? x 'GL:ROTATE)
- (guarantee flo:flonum? y 'GL:ROTATE)
- (guarantee flo:flonum? z 'GL:ROTATE)
+ (guarantee-current 'gl:rotate)
+ (guarantee flo:flonum? x 'gl:rotate)
+ (guarantee flo:flonum? y 'gl:rotate)
+ (guarantee flo:flonum? z 'gl:rotate)
(C-call "glRotated" angle x y z))
(define (gl:translate x y z)
- (guarantee-current 'GL:TRANSLATE)
- (guarantee flo:flonum? x 'GL:TRANSLATE)
- (guarantee flo:flonum? y 'GL:TRANSLATE)
- (guarantee flo:flonum? z 'GL:TRANSLATE)
+ (guarantee-current 'gl:translate)
+ (guarantee flo:flonum? x 'gl:translate)
+ (guarantee flo:flonum? y 'gl:translate)
+ (guarantee flo:flonum? z 'gl:translate)
(C-call "glTranslated" x y z))
(define (gl:viewport x y width height)
- (guarantee-current 'GL:VIEWPORT)
- (guarantee integer? x 'GL:VIEWPORT)
- (guarantee integer? y 'GL:VIEWPORT)
- (guarantee integer? width 'GL:VIEWPORT)
- (guarantee integer? height 'GL:VIEWPORT)
+ (guarantee-current 'gl:viewport)
+ (guarantee integer? x 'gl:viewport)
+ (guarantee integer? y 'gl:viewport)
+ (guarantee integer? width 'gl:viewport)
+ (guarantee integer? height 'gl:viewport)
(C-call "glViewport" x y width height))
(define (gl:flush)
- (guarantee-current 'GL:FLUSH)
+ (guarantee-current 'gl:flush)
(C-call "glFlush"))
(define (glu:look-at position aim up)
- (guarantee-current 'GL:LOOK-AT)
+ (guarantee-current 'gl:look-at)
(C-call "glu_look_at" position aim up))
(define (glu:perspective fovy aspect z-near z-far)
- (guarantee-current 'GL:PERSPECTIVE)
+ (guarantee-current 'gl:perspective)
(C-call "gluPerspective" fovy aspect z-near z-far))
\f
(define param:gl-context-current?)
;;;; Compile the GLX Gears demo.
-(load-option 'CREF)
+(load-option 'cref)
(load "make")
(with-system-library-directories
'("./")
(lambda ()
- (if (name->package '(GL GLX-GEARS))
- (error "The GLX-GEARS package already exists.")
+ (if (name->package '(gl glx-gears))
+ (error "The glx-gears package already exists.")
(let ((package-set (package-set-pathname "glxgears")))
(if (not (file-exists? package-set))
(cref/generate-trivial-constructor "glxgears"))
(env (->environment '(gl glxgears))))
(compile-file "glxgears" deps env)
(load "glxgears" env)))))
-(cref/generate-constructors "glxgears" 'ALL)
\ No newline at end of file
+(cref/generate-constructors "glxgears" 'all)
\ No newline at end of file
(let ((2da (* 2. da))
(3da (* 3. da)))
- (gl:shade-model 'FLAT)
+ (gl:shade-model 'flat)
(gl:normal (flo:3d 0. 0. 1.))
;; draw front face
- (gl:begin 'QUAD-STRIP)
+ (gl:begin 'quad-strip)
(do ((i 0. (+ i 1.)))
((> i teeth))
(let ((angle (* i 2pi/teeth)))
(gl:end)
;; draw front sides of teeth
- (gl:begin 'QUADS)
+ (gl:begin 'quads)
(do ((i 0. (+ i 1.)))
((= i teeth))
(let ((angle (* i 2pi/teeth)))
(gl:normal (flo:3d 0. 0. -1.))
;; draw back face
- (gl:begin 'QUAD-STRIP)
+ (gl:begin 'quad-strip)
(do ((i 0. (+ i 1.)))
((> i teeth))
(let ((angle (* i 2pi/teeth)))
(gl:end)
;; draw back sides of teeth
- (gl:begin 'QUADS)
+ (gl:begin 'quads)
(do ((i 0. (+ i 1.)))
((= i teeth))
(let ((angle (* i 2pi/teeth)))
(gl:end)
;; draw outward faces of teeth
- (gl:begin 'QUAD-STRIP)
+ (gl:begin 'quad-strip)
(do ((i 0. (+ i 1.)))
((= i teeth))
(let ((angle (* i 2pi/teeth)))
(gl:vertex3 (* r1 (cos 0.)) (* r1 (sin 0.)) -width/2)
(gl:end)
- (gl:shade-model 'SMOOTH)
+ (gl:shade-model 'smooth)
;; draw inside radius cylinder
- (gl:begin 'QUAD-STRIP)
+ (gl:begin 'quad-strip)
(do ((i 0. (+ i 1.)))
((> i teeth))
(let ((angle (* i 2pi/teeth)))
(gl:vertex v)))
(define (draw)
- (gl:clear 'COLOR-BUFFER 'DEPTH-BUFFER)
+ (gl:clear 'color-buffer 'depth-buffer)
(gl:push-matrix)
(gl:rotate view-rotx 1. 0. 0.)
(gl:rotate view-roty 0. 1. 0.)
(if stereo
(begin
;; First left eye.
- (gl:draw-buffer 'BACK-LEFT)
+ (gl:draw-buffer 'back-left)
- (gl:matrix-mode 'PROJECTION)
+ (gl:matrix-mode 'projection)
(gl:load-identity)
(gl:frustum left right (- asp) asp 5. 60.)
- (gl:matrix-mode 'MODELVIEW)
+ (gl:matrix-mode 'modelview)
(gl:push-matrix)
(gl:translate (* .5 eyesep) 0. 0.)
(gl:pop-matrix)
;; Then right eye.
- (gl:draw-buffer 'BACK-RIGHT)
+ (gl:draw-buffer 'back-right)
- (gl:matrix-mode 'PROJECTION)
+ (gl:matrix-mode 'projection)
(gl:load-identity)
(gl:frustum (- right) (- left) (- asp) asp 5. 60.)
- (gl:matrix-mode 'MODELVIEW)
+ (gl:matrix-mode 'modelview)
(gl:push-matrix)
(gl:translate (* -.5 eyesep) 0. 0.)
(set! left (* -5. (/ (- w (* .5 eyesep)) fix-point)))
(set! right (* 5. (/ (+ w (* .5 eyesep)) fix-point))))
(let ((h (/ heightf widthf)))
- (gl:matrix-mode 'PROJECTION)
+ (gl:matrix-mode 'projection)
(gl:load-identity)
(gl:frustum -1. 1. (- h) h 5. 60.)))
- (gl:matrix-mode 'MODELVIEW)
+ (gl:matrix-mode 'modelview)
(gl:load-identity)
(gl:translate 0. 0. -40.)))
(green (color 0.0 0.8 0.2 1.0))
(blue (color 0.2 0.2 1.0 1.0)))
(%trace ";light\n")
- (gl:light 'LIGHT0 'POSITION pos)
- (gl:enable 'CULL-FACE)
- (gl:enable 'LIGHTING)
- (gl:enable 'LIGHT0)
- (gl:enable 'DEPTH-TEST)
+ (gl:light 'light0 'position pos)
+ (gl:enable 'cull-face)
+ (gl:enable 'lighting)
+ (gl:enable 'light0)
+ (gl:enable 'depth-test)
;; make the gears
(set! gear1 (gl:gen-lists 1))
(%trace ";gear1 => "gear1"\n")
- (gl:new-list gear1 'COMPILE)
- (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE red)
+ (gl:new-list gear1 'compile)
+ (gl:material 'front 'ambient-and-diffuse red)
(draw-gear 1.0 4.0 1.0 20. 0.7)
(gl:end-list)
(set! gear2 (gl:gen-lists 1))
(%trace ";gear2 => "gear2"\n")
- (gl:new-list gear2 'COMPILE)
- (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE green)
+ (gl:new-list gear2 'compile)
+ (gl:material 'front 'ambient-and-diffuse green)
(draw-gear 0.5 2.0 2.0 10. 0.7)
(gl:end-list)
(set! gear3 (gl:gen-lists 1))
(%trace ";gear3 => "gear3"\n")
- (gl:new-list gear3 'COMPILE)
- (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE blue)
+ (gl:new-list gear3 'compile)
+ (gl:material 'front 'ambient-and-diffuse blue)
(draw-gear 1.3 2.0 0.5 10. 0.7)
(gl:end-list)
- (gl:enable 'NORMALIZE)))
+ (gl:enable 'normalize)))
(define (no-border dpy w)
(declare (ignore dpy w))
(define (handle-event dpy win event)
(declare (ignore dpy win))
;; Handle one X event.
- ;; \return NOP, EXIT or DRAW
+ ;; \return nop, exit or draw
(let ((type (C-> event "XEvent type")))
(cond ((int:= type (C-enum "Expose"))
(%trace ";handle-event Expose\n")
- 'DRAW)
+ 'draw)
((int:= type (C-enum "ConfigureNotify"))
(%trace ";handle-event ConfigureNotify\n")
(reshape (C-> event "XConfigureEvent width")
(C-> event "XConfigureEvent height"))
- 'DRAW)
+ 'draw)
((int:= type (C-enum "KeyPress"))
(%trace ";handle-event KeyPress\n")
(let ((code (C-call "XLookupKeysym" event 0)))
(cond ((int:= code (C-enum "XK_Left"))
(set! view-roty (+ view-roty 5.))
- 'DRAW)
+ 'draw)
((int:= code (C-enum "XK_Right"))
(set! view-roty (- view-roty 5.))
- 'DRAW)
+ 'draw)
((int:= code (C-enum "XK_Up"))
(set! view-rotx (+ view-rotx 5.))
- 'DRAW)
+ 'draw)
((int:= code (C-enum "XK_Down"))
(set! view-rotx (- view-rotx 5.))
- 'DRAW)
+ 'draw)
(else
(let ((buffer (malloc 10 'char)))
(C-call "XLookupString" event buffer 10 0 0)
(free buffer)
(cond ((= buffer0 27)
;; escape
- 'EXIT)
+ 'exit)
((or (= buffer0 (char->ascii #\a))
(= buffer0 (char->ascii #\A)))
(set! animate (not animate))
- 'DRAW)
- (else 'DRAW))))))))
+ 'draw)
+ (else 'draw))))))))
(else
(%trace ";handle-event "type"\n")
- 'NOP))))
+ 'nop))))
(define (event-loop dpy win)
(%trace ";event-loop\n")
(let ((op (handle-event dpy win event)))
(%trace ";handle-event => "op"\n")
(free event)
- (if (memq op '(EXIT DRAW))
+ (if (memq op '(exit draw))
op
(while-loop))))))))
- (if (eq? op 'EXIT)
- 'EXIT
+ (if (eq? op 'exit)
+ 'exit
(begin
(draw-frame dpy win)
(while-loop))))))
(if printInfo
(for-each
display
- (list "GL_RENDERER = "(get-string 'RENDERER)"\n"
- "GL_VERSION = "(get-string 'VERSION)"\n"
- "GL_VENDOR = "(get-string 'VENDOR)"\n"
- "GL_EXTENSIONS = "(get-string 'EXTENSIONS)"\n")))
+ (list "GL_RENDERER = "(get-string 'renderer)"\n"
+ "GL_VERSION = "(get-string 'version)"\n"
+ "GL_VENDOR = "(get-string 'vendor)"\n"
+ "GL_EXTENSIONS = "(get-string 'extensions)"\n")))
(init)
(define (bit-ior . ints)
(reduce bitwise-ior 0 ints))
-(define c-poke-int (make-primitive-procedure 'C-POKE-INT 3))
+(define c-poke-int (make-primitive-procedure 'c-poke-int 3))
(define (get-string symbol)
(utf8->string
;;;; Load the GL option.
-(load-option 'GTK)
+(load-option 'gtk)
(with-loader-base-uri (system-library-uri "gl/")
(lambda ()
(load-package-set "gl")))
#| -*-Scheme-*- |#
-(define-load-option 'GL
+(define-load-option 'gl
(let ((pathname
(merge-pathnames "make"
(directory-pathname (current-load-pathname)))))
(loop skipping?))))))
(parameterize ((param:suppress-loading-message? #t))
- (load-option 'FFI))
+ (load-option 'ffi))
((access rewrite-file (->environment '(ffi build)))
(merge-pathnames "TAGS")
rewriter)))
(begin
(parameterize ((param:suppress-loading-message? #t))
- (load-option 'CREF)
- (load-option 'SOS)
- (load-option 'FFI))
+ (for-each load-option '(cref sos ffi)))
- (if (name->package '(GLIB))
- (error "The GLIB package already exists."))
+ (if (name->package '(glib))
+ (error "The Glib package already exists."))
(let ((package-set (package-set-pathname "glib")))
(if (not (file-modification-time<? "glib.pkg" package-set))
(cref/generate-trivial-constructor "glib"))
'open-input-gfile)
(default-object)
'open-input-gfile)))
- ;;(port/set-coding port 'ISO-8859-1)
- ;;(port/set-line-ending port 'NEWLINE)
+ ;;(port/set-coding port 'iso-8859-1)
+ ;;(port/set-line-ending port 'newline)
port))
(define (->uri* object caller)
'open-output-gfile)
(default-object)
'open-output-gfile)))
- ;;(port/set-coding port 'ISO-8859-1)
- ;;(port/set-line-ending port 'NEWLINE)
+ ;;(port/set-coding port 'iso-8859-1)
+ ;;(port/set-line-ending port 'newline)
port))
(define (make-g-stream-sink gstream)
;;; which, if not null, references a GError that must be freed.
(define-structure gio-cleanup-info
- pending-op ; #f, <opname>, CLOSED or ERROR. The first one
+ pending-op ; #f, <opname>, closed or error. The first one
; means "idle" and the last two are more
; permanent states than "op"s. <opname> might be
- ; OPEN, READ, SKIP, WRITE, QUERY, NEXT, CLOSE,
+ ; open, read, skip, write, query, next, close,
; etc.
callback-id ; #f or op's finish callback ID
gcancellable ; a GCancellable alien
(define-syntax cleanup-callback-id
(sc-macro-transformer
(lambda (form environment)
- (if (syntax-match? '(IDENTIFIER SYMBOL SYMBOL) (cdr form))
+ (if (syntax-match? '(identifier symbol symbol) (cdr form))
(let ((info (close-syntax (cadr form) environment))
(type-name (caddr form))
(slot (cadddr form)))
(let ((accessor (close-syntax
- (symbol type-name '-CLEANUP-INFO- slot)
+ (symbol type-name '-cleanup-info- slot)
environment))
(modifier (close-syntax
- (symbol 'SET- type-name '-CLEANUP-INFO- slot '!)
+ (symbol 'set- type-name '-cleanup-info- slot '!)
environment)))
- `(LET ((ID (,accessor ,info)))
- (IF ID
- (BEGIN
- (DE-REGISTER-C-CALLBACK ID)
- (,modifier ,info #F))))))))))
+ `(let ((id (,accessor ,info)))
+ (if id
+ (begin
+ (de-register-c-callback id)
+ (,modifier ,info #f))))))))))
(define-integrable-operator (cleanup-gerror-pointer gerror*)
(assert-glib-locked 'cleanup-gerror-pointer)
(define-integrable-operator (cleanup-gio gio-info)
(assert-glib-locked 'cleanup-gio)
(let ((pending-op (gio-cleanup-info-pending-op gio-info)))
- (if (not (memq pending-op '(#f ERROR CLOSED)))
+ (if (not (memq pending-op '(#f error closed)))
(C-call "g_cancellable_cancel"
(gobject-alien (gio-cleanup-info-gcancellable gio-info)))))
(cleanup-callback-id gio-info gio callback-id)
(define-integrable (guarantee-gio-idle gio)
(let* ((gio-info (gio-cleanup-info gio))
(pending-op (gio-cleanup-info-pending-op gio-info)))
- (if (not (memq pending-op '(#f ERROR CLOSED)))
+ (if (not (memq pending-op '(#f error closed)))
(error "Operation pending:" gio))
(if pending-op
(error "Not open:" gio))))
(guarantee-gio-idle gstream)
(let* ((count (fix:- end start))
(async-buffer (ensure-buffer gstream count)))
- (set-gio-cleanup-info-pending-op! gio-info 'READ)
+ (set-gio-cleanup-info-pending-op! gio-info 'read)
(C-call "g_input_stream_read_async"
(gobject-alien gstream)
async-buffer
(value (dequeue! queue)))
(if (string? value)
(begin
- (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
+ (set-gio-cleanup-info-pending-op! gio-info 'error)
(error "Error reading:" gstream value))
(begin
(c-peek-bytes async-buffer 0 value buffer start)
(info (g-input-stream-cleanup-info gstream))
(callback-id (g-input-stream-cleanup-info-skip-id info)))
(guarantee-gio-idle gstream)
- (set-gio-cleanup-info-pending-op! gio-info 'SKIP)
+ (set-gio-cleanup-info-pending-op! gio-info 'skip)
(C-call "g_input_stream_skip_async"
(gobject-alien gstream)
count
(value (dequeue! queue)))
(if (string? value)
(begin
- (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
+ (set-gio-cleanup-info-pending-op! gio-info 'error)
(error "Error skipping:" gstream value))
(begin
(set-gio-cleanup-info-pending-op! gio-info #f)
(let ((old (gio-cleanup-info-callback-id gio-info)))
(if old (de-register-c-callback old)))
(let ((id (make-callback queue gerror*)))
- (set-gio-cleanup-info-pending-op! gio-info 'CLOSE)
+ (set-gio-cleanup-info-pending-op! gio-info 'close)
(set-gio-cleanup-info-callback-id! gio-info id)
id)))))
(callout (gobject-alien gio)
(cond ((eq? value #t)
(without-interruption
(lambda ()
- (set-gio-cleanup-info-pending-op! gio-info 'CLOSED)
+ (set-gio-cleanup-info-pending-op! gio-info 'closed)
(cleanup gio-info)))
unspecific)
((string? value)
- (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
+ (set-gio-cleanup-info-pending-op! gio-info 'error)
(error "Error during close:" gio value))
(else
(error "Unexpected:" value gio)))))))
(guarantee-gio-idle gstream)
(let* ((count (fix:- end start))
(async-buffer (ensure-buffer gstream count)))
- (set-gio-cleanup-info-pending-op! gio-info 'WRITE)
+ (set-gio-cleanup-info-pending-op! gio-info 'write)
(c-poke-bytes async-buffer 0 count buffer start)
(C-call "g_output_stream_write_async"
(gobject-alien gstream)
(value (dequeue! queue)))
(if (string? value)
(begin
- (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
+ (set-gio-cleanup-info-pending-op! gio-info 'error)
(error "Error writing:" gstream value))
(begin
(set-gio-cleanup-info-pending-op! gio-info #f)
(info (g-output-stream-cleanup-info gstream))
(callback-id (g-output-stream-cleanup-info-flush-id info)))
(guarantee-gio-idle gstream)
- (set-gio-cleanup-info-pending-op! gio-info 'FLUSH)
+ (set-gio-cleanup-info-pending-op! gio-info 'flush)
(C-call "g_output_stream_flush_async"
(gobject-alien gstream)
(gio-priority gstream)
(value (dequeue! queue)))
(if (string? value)
(begin
- (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
+ (set-gio-cleanup-info-pending-op! gio-info 'error)
(error "Error flushing:" gstream value))
(begin
(set-gio-cleanup-info-pending-op! gio-info #f)
(define (gfile-read gfile)
(assert-glib-locked 'gfile-read)
- (gfile-open gfile 'OPEN
+ (gfile-open gfile 'open
make-g-input-stream
(named-lambda (open-callout
gfile* priority gcancellable* callback id)
(gfile-mount gfile)
(retry))
((string? value)
- (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
+ (set-gio-cleanup-info-pending-op! gio-info 'error)
(error (string-append (uri->string (gfile-uri gfile))":") value))
(else
(error "Unexpected:" value gstream)))))))
(define (gfile-append-to gfile . flags)
(assert-glib-locked 'gfile-append-to)
(let ((flags* (->gfile-create-flags flags)))
- (gfile-open gfile 'APPEND-TO
+ (gfile-open gfile 'append-to
make-g-output-stream
(named-lambda (append-to-callout
gfile* priority gcancellable* callback id)
(define (->gfile-create-flag flag)
(case flag
- ((PRIVATE) (C-enum "G_FILE_CREATE_PRIVATE"))
- ((REPLACE) (C-enum "G_FILE_CREATE_REPLACE_DESTINATION"))
+ ((private) (C-enum "G_FILE_CREATE_PRIVATE"))
+ ((replace) (C-enum "G_FILE_CREATE_REPLACE_DESTINATION"))
(else (error:wrong-type-argument flag "GFile create flag"
- '->GFILE-CREATE-FLAG))))
+ '->gfile-create-flag))))
(define (make-append-to-finish-callback alien queue gerror*)
(C-callback
(named-lambda (append-to-finish-callback source result)
(assert-glib-locked 'append-to-finish-callback)
(C-call "g_file_append_to_finish" alien source result gerror*)
- (g-output-stream-finish alien queue gerror* 'APPEND-TO))))
+ (g-output-stream-finish alien queue gerror* 'append-to))))
(define (g-output-stream-finish alien queue gerror* op)
(assert-glib-locked 'g-output-stream-finish)
(define (gfile-create gfile . flags)
(assert-glib-locked 'gfile-create)
(let ((flags* (->gfile-create-flags flags)))
- (gfile-open gfile 'CREATE
+ (gfile-open gfile 'create
make-g-output-stream
(named-lambda (create-callout
gfile* priority gcancellable* callback id)
(named-lambda (create-finish-callback source result)
(assert-glib-locked 'create-finish-callback)
(C-call "g_file_create_finish" alien source result gerror*)
- (g-output-stream-finish alien queue gerror* 'CREATE))))
+ (g-output-stream-finish alien queue gerror* 'create))))
(define (gfile-replace gfile etag backup? . flags)
(assert-glib-locked 'gfile-replace)
(let ((etag (->gfile-etag etag))
(make-backups (if backup? 1 0))
(flags* (->gfile-create-flags flags)))
- (gfile-open gfile 'REPLACE
+ (gfile-open gfile 'replace
make-g-output-stream
(named-lambda (replace-callout
gfile* priority gcancellable* callback id)
((or (eq? etag #f) (zero? etag))
0)
(else
- (error:wrong-type-argument etag "GFile etag" '->GFILE-ETAG))))
+ (error:wrong-type-argument etag "GFile etag" '->gfile-etag))))
(define (make-replace-finish-callback alien queue gerror*)
(C-callback
(named-lambda (replace-finish-callback source result)
(assert-glib-locked 'replace-finish-callback)
(C-call "g_file_replace_finish" alien source result gerror*)
- (g-output-stream-finish alien queue gerror* 'REPLACE))))
+ (g-output-stream-finish alien queue gerror* 'replace))))
\f
(define-class (<gfile-info> (constructor ()))
(<gio>))
(define (gfile-query-info gfile attributes follow-symlinks?)
(guarantee string? attributes 'gfile-query-info)
(assert-glib-locked 'gfile-query-info)
- (gfile-open gfile 'QUERY
+ (gfile-open gfile 'query
make-gfile-info
(named-lambda (query-callout
gfile* priority gcancellable* callback id)
(named-lambda (cleanup-gfile-info gfile-info queue gerror*)
(declare (ignore queue gerror*))
(let ((gio-info (gio-cleanup-info gfile-info)))
- (set-gio-cleanup-info-pending-op! gio-info 'CLOSED)
+ (set-gio-cleanup-info-pending-op! gio-info 'closed)
(cleanup-gio gio-info)))))
(define (make-query-finish-callback alien queue gerror*)
(define (gfile-enumerate-children gfile attributes follow-symlinks?)
(guarantee string? attributes 'gfile-enumerate-children)
(assert-glib-locked 'gfile-enumerate-children)
- (gfile-open gfile 'OPEN
+ (gfile-open gfile 'open
make-gfile-enumerator
(named-lambda (query-callout
gfile* priority gcancellable* callback id)
(let* ((gio-info (gio-cleanup-info genum))
(callback-id (gio-cleanup-info-callback-id gio-info)))
(guarantee-gio-idle genum)
- (set-gio-cleanup-info-pending-op! gio-info 'NEXT)
+ (set-gio-cleanup-info-pending-op! gio-info 'next)
(C-call "g_file_enumerator_next_files_async"
(gobject-alien genum)
nfiles
(value (dequeue! queue)))
(if (string? value)
(begin
- (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
+ (set-gio-cleanup-info-pending-op! gio-info 'error)
(error "Error in gfile-enumerator-next-files:" genum value))
(begin
(set-gio-cleanup-info-pending-op! gio-info #f)
(without-interruption ;don't leak callback IDs
(lambda ()
(let ((id (make-mount-finish-callback queue gerror*)))
- (set-gio-cleanup-info-pending-op! gio-info 'MOUNT)
+ (set-gio-cleanup-info-pending-op! gio-info 'mount)
(set-gio-cleanup-info-callback-id! gio-info id)
id)))))
(let ((userinfo (uri-authority-userinfo (uri-authority (gfile-uri gfile)))))
(prompt-for-mount-auth gmountop)
(retry))
((string? value)
- (set-gio-cleanup-info-pending-op! gio-info 'ERROR)
+ (set-gio-cleanup-info-pending-op! gio-info 'error)
(error (string-append (uri->string (gfile-uri gfile))":") value))
((eq? value #t)
(set-gio-cleanup-info-pending-op! gio-info #f)
(alien (gobject-alien gmountop))
(port (interaction-i/o-port)))
(if message (display message port))
- (if (and (memq 'ANONYMOUS-SUPPORTED flags)
+ (if (and (memq 'anonymous-supported flags)
(without-glib-lock
(lambda ()
(prompt-for-confirmation "Login anonymously" port))))
(begin
(C-call "g_mount_operation_set_anonymous" alien 1)
(set-g-mount-operation-username! alien "anonymous")))
- (if (memq 'NEED-DOMAIN flags)
+ (if (memq 'need-domain flags)
(let ((d (prompt-for-string* "Domain" domain port)))
(C-call "g_mount_operation_set_domain" alien (string->utf8 d))
(set-g-mount-operation-domain! gmountop d)))
- (if (memq 'NEED-USERNAME flags)
+ (if (memq 'need-username flags)
(let ((u (prompt-for-string* "Username" username port)))
(C-call "g_mount_operation_set_username" alien (string->utf8 u))
(set-g-mount-operation-username! gmountop u)))
- (if (memq 'NEED-PASSWORD flags)
+ (if (memq 'need-password flags)
(let ((password))
(dynamic-wind
(lambda () unspecific)
(C-call "g_mount_operation_set_password" alien password))
(lambda ()
(bytevector-fill! password #x55)))))
- (if (memq 'SAVING-SUPPORTED flags)
+ (if (memq 'saving-supported flags)
(if (without-glib-lock
(lambda ()
(prompt-for-confirmation "Save password permanently" port)))
(cons symbol rest)
rest))
(cons-flags
- (C-enum "G_ASK_PASSWORD_NEED_PASSWORD") 'NEED-PASSWORD
+ (C-enum "G_ASK_PASSWORD_NEED_PASSWORD") 'need-password
(cons-flags
- (C-enum "G_ASK_PASSWORD_NEED_USERNAME") 'NEED-USERNAME
+ (C-enum "G_ASK_PASSWORD_NEED_USERNAME") 'need-username
(cons-flags
- (C-enum "G_ASK_PASSWORD_NEED_DOMAIN") 'NEED-DOMAIN
+ (C-enum "G_ASK_PASSWORD_NEED_DOMAIN") 'need-domain
(cons-flags
- (C-enum "G_ASK_PASSWORD_SAVING_SUPPORTED") 'SAVING-SUPPORTED
+ (C-enum "G_ASK_PASSWORD_SAVING_SUPPORTED") 'saving-supported
(cons-flags
- (C-enum "G_ASK_PASSWORD_ANONYMOUS_SUPPORTED") 'ANONYMOUS-SUPPORTED
+ (C-enum "G_ASK_PASSWORD_ANONYMOUS_SUPPORTED") 'anonymous-supported
'()))))))
(define (make-mount-question-callback gfile)
(define-syntax %trace
(syntax-rules ()
- ((_ ARGS ...)
- (if %trace? (outf-error ARGS ...)))))
+ ((_ args ...)
+ (if %trace? (outf-error args ...)))))
(define %trace-auth? #t)
(define-syntax %trace-auth
(syntax-rules ()
- ((_ ARGS ...)
- (if %trace? (outf-error ARGS ...)))))
\ No newline at end of file
+ ((_ args ...)
+ (if %trace? (outf-error args ...)))))
\ No newline at end of file
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
# 02110-1301, USA.
-# Test the GLIB option: copy text file.
+# Test the GLib option: copy text file.
#
# Copy lines from a text file to a new file and compare the two.
: ${MIT_SCHEME_EXE=mit-scheme}
${MIT_SCHEME_EXE} --prepend-library . <<\EOF
(begin
- (load-option 'GLIB)
+ (load-option 'glib)
(load "glib-tests")
(let ((file1 "glib.texi")
(file2 "test-copy-1.txt"))
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
# 02110-1301, USA.
-# Test the GLIB option: list the current directory.
+# Test the GLib option: list the current directory.
#
# List the current directory using GIO and directory-read, and compare
# the results.
: ${MIT_SCHEME_EXE=mit-scheme}
${MIT_SCHEME_EXE} --prepend-library . <<\EOF
(begin
- (load-option 'GLIB)
+ (load-option 'glib)
(load "glib-tests")
(let ((native (sort (ls "./") string<?))
(gio (sort (gls "./") string<?)))
(define (glib-start)
;; Called from glib/make.scm, from a (load-option 'Glib).
(if (not (plugin-available? "glib"))
- (error "GLIB plugin not found"))
+ (error "GLib plugin not found"))
(if (fix:zero? (with-glib-lock
(lambda ()
(C-call "start_glib"))))
#;(er-macro-transformer
(lambda (form rename compare)
(declare (ignore compare))
- (cond ((syntax-match? '((IDENTIFIER . MIT-BVL) + FORM) (cdr form))
- (let ((r-begin (rename 'BEGIN))
- (r-declare (rename 'DECLARE))
- (r-define (rename 'DEFINE)))
+ (cond ((syntax-match? '((identifier . mit-bvl) + form) (cdr form))
+ (let ((r-begin (rename 'begin))
+ (r-declare (rename 'declare))
+ (r-define (rename 'define)))
`(,r-begin
- (,r-declare (INTEGRATE-OPERATOR ,(caadr form)))
+ (,r-declare (integrate-operator ,(caadr form)))
(,r-define ,@(cdr form)))))
(else
(ill-formed-syntax form)))))
(rsc-macro-transformer
(lambda (form environment)
(declare (ignore environment))
- (if (syntax-match? '((IDENTIFIER . MIT-BVL) + FORM) (cdr form))
- `(BEGIN
- (DECLARE (INTEGRATE-OPERATOR ,(caadr form)))
- (DEFINE ,@(cdr form)))
+ (if (syntax-match? '((identifier . mit-bvl) + form) (cdr form))
+ `(begin
+ (declare (integrate-operator ,(caadr form)))
+ (define ,@(cdr form)))
(ill-formed-syntax form)))))
(define-syntax error-if-null
(syntax-rules ()
- ((_ ALIEN MESSAGE ...)
- (if (alien-null? ALIEN)
- (error MESSAGE ...)))))
+ ((_ alien message ...)
+ (if (alien-null? alien)
+ (error message ...)))))
(define-integrable-operator (fix:max n m) (if (fix:> n m) n m))
(if (fix:negative? n) (fix:negate n) n))
(define-integrable (bit-mask-indices num)
- ;; The indices of the bits set in NUM.
+ ;; The indices of the bits set in num.
(let ((str (unsigned-integer->bit-string 32 num)))
(let loop ((start 0))
(let ((next (bit-substring-find-next-set-bit str start 32)))
(call-with-current-continuation
(lambda (continue)
;;(with-restart name reporter effector interactor thunk)
- (with-restart 'ABORT
+ (with-restart 'abort
(string-append "Punt "what"; return to the GLib main loop.")
(named-lambda (glib-abort-effector . args)
(declare (ignore args))
(define (g-signal-connect gobject alien-function callback
#!optional signal-name)
- ;; Specify SIGNAL-NAME if it is not the same as ALIEN-FUNCTION's name.
+ ;; Specify signal-name if it is not the same as alien-function's name.
(guarantee-gobject gobject 'g-signal-connect)
(guarantee-alien-function alien-function 'g-signal-connect)
(assert-glib-locked 'g-signal-connect)
(not (fix:zero? (fix:and fixnum mask))))
(define (check-prop-name name)
- ;; Allows NAME to be a symbol OR string.
+ ;; Allows name to be a symbol OR string.
(cond ((symbol? name) (symbol->string name))
((string? name) name)
(else (check-prop-name
-The GTK-SCREEN option.
+The gtk-screen option.
This option is a Gtk+-based screen type for Edwin. After loading this
option, the old X11 display type is shadowed. The new screen type
To try it out:
- (load-option 'GTK-SCREEN)
+ (load-option 'gtk-screen)
(spawn-edit)
Enable it for future editing sessions by creating a ~/.edwin file
containing:
- (load-option 'GTK-SCREEN)
+ (load-option 'gtk-screen)
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
# 02110-1301, USA.
-# Test the GTK-SCREEN option.
+# Test the gtk-screen option.
set -e
: ${MIT_SCHEME_EXE=mit-scheme}
${MIT_SCHEME_EXE} --prepend-library . --batch-mode <<\EOF
(begin
- (load-option 'GTK-SCREEN)
+ (load-option 'gtk-screen)
(if (gtk-initialized?)
(let ((env (->environment '(gtk gtk-widget))))
(c-peek-cstring alien)
alien)))
(access malloced-aliens ffi))))))
- (warn "Could not test the GTK-SCREEN option without a DISPLAY."))
+ (warn "Could not test the gtk-screen option without a DISPLAY."))
)
EOF
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
# 02110-1301, USA.
-# Compile the GTK-SCREEN option.
+# Compile the gtk-screen option.
set -e
: ${MIT_SCHEME_EXE=mit-scheme}
(load-option 'gtk)
(load-option 'edwin))
- (if (name->package '(EDWIN SCREEN GTK-SCREEN))
- (error "The (EDWIN SCREEN GTK-SCREEN) package already exists."))
+ (if (name->package '(edwin screen gtk-screen))
+ (error "The (edwin screen gtk-screen) package already exists."))
(let ((package-set (package-set-pathname "gtk-screen")))
(if (not (file-modification-time<? "gtk-screen.pkg" package-set))
(cref/generate-trivial-constructor "gtk-screen"))
#| -*- Scheme -*- |#
-;;;; GTK-SCREEN buffer packaging info
+;;;; Gtk Screen buffer packaging info
(standard-scheme-find-file-initialization
'#(
|#
-;;;; Support for the FACE text property.
+;;;; Support for the "face" text property.
;;; package: (edwin screen gtk-screen)
(define-command add-text-property
image image-start image-end
tab-width column-offset char-image-strings
receiver)
- ;; Like GROUP-LINE-IMAGE!, but includes Pango markup. RECEIVER will
- ;; be called with the start of the next line or END, and the number
+ ;; Like group-line-image!, but includes Pango markup. Receiver will
+ ;; be called with the start of the next line or end, and the number
;; of characters of markup generated.
(let* ((context (make-markup-context image image-start image-end
column-offset
(rsc-macro-transformer
(lambda (form environment)
(declare (ignore environment))
- (if (syntax-match? '((IDENTIFIER . MIT-BVL) + FORM) (cdr form))
- `(BEGIN
- (DECLARE (INTEGRATE-OPERATOR ,(caadr form)))
- (DEFINE ,@(cdr form)))
+ (if (syntax-match? '((identifier . mit-bvl) + form) (cdr form))
+ `(begin
+ (declare (integrate-operator ,(caadr form)))
+ (define ,@(cdr form)))
(ill-formed-syntax form)))))
(define-integrable-operator (start-face! face)
((fix:= index end)
(stop-face! face)
end)
- ((get-text-property group index 'INVISIBLE #f)
+ ((get-text-property group index 'invisible #f)
(let ((next (next-specific-property-change group index end
- 'INVISIBLE)))
+ 'invisible)))
(if next
(loop next face)
(begin
(image-tab!)
(loop (fix:1+ index) face))
(else
- (let ((face* (get-text-property group index 'FACE #f)))
+ (let ((face* (get-text-property group index 'face #f)))
(if (not (eq? face* face))
(begin
(stop-face! face)
|#
-;;;; A GTK-based <screen> for Edwin.
+;;;; A Gtk-based <screen> for Edwin.
;;; Package: (edwin screen gtk-screen)
(define-class (<gtk-screen>
(define (init-font-dimensions! screen spec)
(%trace "; init-font-dimensions! "screen" "spec"\n")
- ;; Lookup SCREEN's font via the toplevel widget's pango-context,
+ ;; Lookup screen's font via the toplevel widget's pango-context,
;; which appears to be available before toplevel is realized.
(let* ((toplevel (gtk-screen-toplevel screen))
(define-syntax %trace3
(syntax-rules ()
- ((_ ARGS ...) (if %trace-blinker? (outf-error ARGS ...)))))
+ ((_ args ...) (if %trace-blinker? (outf-error args ...)))))
(create-thread
#f
(%trace "; screen/window-scroll-y-absolute! "screen" "frame" "y-point"\n")
(assert-glib-locked '(screen/window-scroll-y-absolute! <gtk-screen>))
(with-updated-window
- screen frame 'SCROLL-Y-ABSOLUTE!
+ screen frame 'scroll-y-absolute!
(lambda (widget)
(let ((cursor (text-widget-cursor-ink widget))
(view (fix-layout-view widget)))
(%trace "; screen/window-scroll-y-relative! "screen" "frame" "delta"\n")
(assert-glib-locked '(screen/window-scroll-y-relative! <gtk-screen>))
(with-updated-window
- screen frame 'SCROLL-Y-RELATIVE!
+ screen frame 'scroll-y-relative!
(lambda (widget)
(let ((view (fix-layout-view widget))
(delta* (row->y screen delta)))
(%trace "; screen/set-window-start-mark! "screen" "frame" "mark" "force?"\n")
(assert-glib-locked '(screen/set-window-start-mark! <gtk-screen>))
(with-updated-window
- screen frame 'SET-START-MARK!
+ screen frame 'set-start-mark!
(lambda (widget)
(let ((view (fix-layout-view widget))
(line (find-line-at mark widget)))
(%trace "; screen/window-mark-visible? "screen" "frame" "mark"\n")
(assert-glib-locked '(screen/window-mark-visible? <gtk-screen>))
(with-updated-window
- screen frame 'MARK-VISIBLE?
+ screen frame 'mark-visible?
(lambda (widget)
(let ((view (fix-layout-view widget))
(line (find-line-at mark widget)))
(%trace "; screen/window-mark->x "screen" "frame" "mark"\n")
(assert-glib-locked '(screen/window-mark->x <gtk-screen>))
(with-updated-window
- screen frame 'MARK->X
+ screen frame 'mark->x
(lambda (widget)
(let ((line (find-line-at mark widget)))
(if (not line)
(%trace "; screen/window-mark->y "screen" "frame" "mark"\n")
(assert-glib-locked '(screen/window-mark->y <gtk-screen>))
(with-updated-window
- screen frame 'MARK->Y
+ screen frame 'mark->y
(lambda (widget)
(let ((line (find-line-at mark widget)))
(if (not line)
(%trace "; screen/window-mark->coordinates "screen" "frame" "mark"\n")
(assert-glib-locked '(screen/window-mark->coordinates <gtk-screen>))
(with-updated-window
- screen frame 'MARK->COORDINATES
+ screen frame 'mark->coordinates
(lambda (widget)
(let ((line (find-line-at mark widget)))
(if (not line)
(%trace-buttons "coordinates->mark "screen" "frame" "x" "y)
(assert-glib-locked '(screen/window-coordinates->mark! <gtk-screen>))
(with-updated-window
- screen frame 'COORDINATES->MARK
+ screen frame 'coordinates->mark
(lambda (widget)
(let ((drawing (fix-layout-drawing widget))
(view (fix-layout-view widget))
(declare (integrate-operator update-start-mark))
(define (update-start-mark widget)
- ;; Set WIDGET's window's start-mark to the start of the first
+ ;; Set widget's window's start-mark to the start of the first
;; completely visible line ink.
(let ((line (find-line-after (fix-rect-y (fix-layout-view widget)) widget)))
(move-mark-to! (get-start-mark widget)
(define (update-point widget)
(%trace "; update-point "widget"\n")
- ;; Move WIDGET's window's point into view at the beginning of the
+ ;; Move widget's window's point into view at the beginning of the
;; nearest (first or last) completely visible line.
(declare (integrate-operator move-point))
(no-line-start widget)))
(define (find-line-at point widget)
- ;; Return the line-ink that includes the character at POINT. If
+ ;; Return the line-ink that includes the character at point. If
;; there is no such line, return #f or the last line found.
(let loop ((inks (fix-drawing-display-list
(fix-layout-drawing widget)))
(suspend-current-thread))))
(cond ((not (queue-empty? event-queue))
(%trace2 ";block-for-event-until input-event\n")
- 'INPUT-EVENT)
+ 'input-event)
(output-available?
(%trace2 ";block-for-event-until process-output\n")
- 'PROCESS-OUTPUT)
+ 'process-output)
(inferior-thread-changes?
(%trace2 ";block-for-event-until inferior-thread-output\n")
- 'INFERIOR-THREAD-OUTPUT)
+ 'inferior-thread-output)
((process-status-changes?)
(%trace2 ";block-for-event-until process-status\n")
- 'PROCESS-STATUS)
+ 'process-status)
(timeout?
- 'TIMEOUT)
+ 'timeout)
(else
(loop)))))
(lambda ()
(%trace2 ";probe-for-event\n")
(cond ((not (queue-empty? event-queue))
(%trace2 ";probe-for-event input-event\n")
- 'INPUT-EVENT)
+ 'input-event)
((process-output-available?)
(%trace2 ";probe-for-event process-output\n")
- 'PROCESS-OUTPUT)
+ 'process-output)
(inferior-thread-changes?
(%trace2 ";probe-for-event inferior-thread-output\n")
- 'INFERIOR-THREAD-OUTPUT)
+ 'inferior-thread-output)
((process-status-changes?)
(%trace2 ";probe-for-event process-status\n")
- 'PROCESS-STATUS)
+ 'process-status)
(else
(%trace2 ";probe-for-event none\n")
- 'TIMEOUT)))
+ 'timeout)))
(define (block-for-input-event event-queue msec)
(let ((time (and msec (not (zero? msec))
(case (if (and msec (zero? msec))
(probe-for-event event-queue)
(block-for-event-until event-queue time))
- ((INPUT-EVENT)
+ ((input-event)
#t)
- ((PROCESS-STATUS)
+ ((process-status)
(with-glib-lock
(lambda ()
(if (handle-process-status-changes)
(update-screens! #f))))
(loop))
- ((PROCESS-OUTPUT)
+ ((process-output)
(with-glib-lock
(lambda ()
(if (accept-process-output)
(update-screens! #f))))
(loop))
- ((INFERIOR-THREAD-OUTPUT)
+ ((inferior-thread-output)
(with-glib-lock
(lambda ()
(if (accept-thread-output)
(update-screens! #f))))
(loop))
- ((TIMEOUT)
+ ((timeout)
#f)
(else (error "Unexpected value.")))))))
(%trace "; Visibility: "state" "widget"\n")
(let ((screen (edwin-widget-screen widget)))
(case state
- ((VISIBLE) (set-screen-visibility! screen 'VISIBLE))
- ((PARTIALLY-OBSCURED) (set-screen-visibility! screen 'PARTIALLY-OBSCURED))
- ((OBSCURED) (set-screen-visibility! screen 'OBSCURED))
+ ((visible) (set-screen-visibility! screen 'visible))
+ ((partially-obscured) (set-screen-visibility! screen 'partially-obscured))
+ ((obscured) (set-screen-visibility! screen 'obscured))
(else (warn "unexpected visibility state:" state))))
#t)
(let* ((screen (edwin-widget-screen widget))
(thread (gtk-screen-editor-thread screen)))
(%trace "; pushing ^G in "(current-thread)"...\n")
- (queue/push! (gtk-screen-event-queue screen) #\BEL)
+ (queue/push! (gtk-screen-event-queue screen) #\alarm)
(%trace "; signaling "thread"\n")
(signal-thread-event
thread
(%trace-buttons "down "button" "modifiers" "x" "y" "widget)
(queue-input-event (edwin-widget-screen widget)
(make-input-event
- 'BUTTON
+ 'button
execute-gtk-button-command
widget button modifiers x y))
#t)
(define (modifiers->char-bits modifiers)
(reduce bitwise-ior 0 (map (lambda (modifier)
(case modifier
- ((META) char-bit:meta)
- ((CONTROL) char-bit:control)
- ((SUPER) char-bit:super)
- ((HYPER) char-bit:hyper)
+ ((meta) char-bit:meta)
+ ((control) char-bit:control)
+ ((super) char-bit:super)
+ ((hyper) char-bit:hyper)
(else 0)))
modifiers)))
\f
(define (initialize-package!)
(set! screen-list '())
(set! gtk-display-type
- (make-display-type 'GTK
+ (make-display-type 'gtk
#t
gtk-initialized?
make-gtk-screen
(define (re-pack-combo! combo widget prefix)
(%trace "; "prefix"re-pack-combo! "combo" "widget"\n")
- ;; WIDGET should be a match, orientation-wise.
+ ;; Widget should be a match, orientation-wise.
(assert (and (combination? combo)
(if (combination-vertical? combo)
(gtk-vpaned? widget)
(%trace "; "prefix"re-pack-combo-child! "child" "paned"\n")
(let ((next (window-next child)))
(if (not next)
- ;; If last, re-pack CHILD as PANED's child2.
+ ;; If last, re-pack child as paned's child2.
(gtk-paned-pack2-if (re-pack! child (gtk-paned-get-child2 paned)
prefix)
paned prefix)
- ;; Else as PANED's child1. Init child2 and loop.
+ ;; Else as paned's child1. Init child2 and loop.
(begin
(gtk-paned-pack1-if (re-pack! child (gtk-paned-get-child1 paned)
prefix)
(if (window-next next)
(find/create-paned paned
vertical? prefix)
- ;; If last, use PANED's child2.
+ ;; If last, use paned's child2.
paned)
vertical? prefix)))))
(gtk-screen-toplevel screen)))
(define (every-text-widget screen predicate)
- ;; Returns #t iff PREDICATE returns #t for every text widget on the
+ ;; Returns #t iff predicate returns #t for every text widget on the
;; screen.
(every-child (lambda (widget)
(or (not (text-widget? widget))
(set-fix-widget-focus-change-handler! widget focus-change-handler)
(set-fix-widget-visibility-notify-handler! widget visibility-notify-handler)
(set-fix-widget-key-press-handler! widget key-press-handler)
- (set-fix-widget-button-handler! widget 'PRESS button-down-handler)
+ (set-fix-widget-button-handler! widget 'press button-down-handler)
widget)
(define-method gtk-widget-destroy-callback ((widget <text-widget>))
(not (fix-rect-height geometry)))
;; Unfortunately a widget can be realized before it is
;; allocated a size -- when it is added to a realized
- ;; container. In this case, initialize WIDGET's size to
+ ;; container. In this case, initialize widget's size to
;; something reasonable.
(let ((window (text-widget-buffer-frame widget))
(screen (edwin-widget-screen widget)))
(queue-input-event
screen
(make-input-event
- 'SET-WINDOW-SIZE
+ 'set-window-size
(lambda (widget)
(%trace "; input event: set-window-size "widget"\n")
(let ((geometry (fix-widget-geometry widget))
(not (fix-rect-height geometry)))
;; Unfortunately a widget can be realized before it is
;; allocated a size -- when it is added to a realized
- ;; container. In this case, initialize WIDGET's size to
+ ;; container. In this case, initialize widget's size to
;; something reasonable.
(begin
(%trace "; uninitialized geometry: "geometry"\n")
((display-style/no-screen-output? display-style)
(invalidate-all-drawings! screen)
(%trace "; (update-screen! <gtk-screen>) done: no-output\n")
- 'NO-OUTPUT)
- ((not (memq (screen-visibility screen) '(VISIBLE PARTIALLY-OBSCURED)))
+ 'no-output)
+ ((not (memq (screen-visibility screen) '(visible partially-obscured)))
(let ((visibility (screen-visibility screen)))
- (if (not (eq? visibility 'DELETED))
+ (if (not (eq? visibility 'deleted))
(update-name screen))
(invalidate-all-drawings! screen)
(%trace "; (update-screen! <gtk-screen>) done: "visibility"\n")
(set-fix-layout-drawing! widget new-drawing 0 0))))))
(define (re-cursor widget drawing)
- ;; Re-set text-WIDGET-cursor-ink per new buffer in DRAWING.
+ ;; Re-set text-widget-cursor-ink per new buffer in drawing.
(%trace ";\tre-cursor "widget" "drawing"\n")
(let ((cursor (text-widget-cursor-ink widget))
(modeline (text-widget-modeline widget)))
(define (drawing-match? drawing)
;; #t iff nothing has changed, in terms of drawing style
- ;; parameters, between WINDOW and DRAWING.
+ ;; parameters, between window and drawing.
(let ((bufwin (frame-text-inferior window)))
(and (fix:= (%window-tab-width bufwin)
(buffer-drawing-tab-width drawing))
window format (ref-variable frame-name-length buffer))))))
\f
(define (update-drawing screen drawing)
- ;; Redraw a buffer-DRAWING.
+ ;; Redraw a buffer-drawing.
(%trace "; update-drawing "screen" "drawing"\n")
;; This is the traditional Emacs layout, in a fixed-width font, with
(define-syntax %trace3
(syntax-rules ()
- ((_ ARGS ...) (if %trace-redraw?
- (apply outf-error (%trace-simplify ARGS ...))))))
+ ((_ args ...) (if %trace-redraw?
+ (apply outf-error (%trace-simplify args ...))))))
(define-integrable (main)
(%trace3 ";\tdrawing/buffer ticks:"
args))
(define (redraw-line! line x y pango-layout)
- ;; Updates LINE by (re)parsing its buffer. (Re)Images and
- ;; (re)lays-out the line to get its dimensions. (Re)sizes LINE and
- ;; (re)positions it at (X, Y). A separate PANGO-LAYOUT is (re)used
+ ;; Updates line by (re)parsing its buffer. (Re)Images and
+ ;; (re)lays-out the line to get its dimensions. (Re)sizes line and
+ ;; (re)positions it at (X, Y). A separate pango-layout is (re)used
;; during this process, and any cached layout is cleared.
(define-syntax %trace3
(syntax-rules ()
- ((_ ARGS ...) (if %trace-redraw?
- (apply outf-error (%trace-simplify ARGS ...))))))
+ ((_ args ...) (if %trace-redraw?
+ (apply outf-error (%trace-simplify args ...))))))
(%trace3 ";\t redraw-line! "line" from "(line-ink-start line)
" ("x","y") with "pango-layout"\n")
;; Common trivial case: no change = unchanged.
(not change-start)
- ;; First case: the change region ends before LINE starts.
+ ;; First case: the change region ends before line starts.
;;
- ;; LINE and change region may not touch. The change region may
- ;; have removed the newline before LINE, or inserted new text
- ;; after the newline, changing LINE's start.
+ ;; Line and change region may not touch. The change region may
+ ;; have removed the newline before line, or inserted new text
+ ;; after the newline, changing line's start.
(let ((line-start (line-ink-start-index line)))
(fix:< change-end line-start))
- ;; Second case: the change region starts after LINE ends.
+ ;; Second case: the change region starts after line ends.
;;
- ;; LINE must end with a newline, else a change region touching
+ ;; Line must end with a newline, else a change region touching
;; the end is adding to the line. Rather than test for this,
;; consider touching lines as NOT unchanged.
(let ((line-end (line-ink-end-index line)))
(main)))
(define (image-column point line)
- ;; Returns the index of the character at POINT within LINE's image.
+ ;; Returns the index of the character at point within line's image.
(let* ((drawing (fix-ink-drawing line))
(buffer (buffer-drawing-buffer drawing))
(group (buffer-group buffer)))
(set-fix-ink-widgets! cursor '())))))))
(define (blink! screen cursor)
- ;; Atomically sets CURSOR up to blink. CURSOR may be #f, in which
+ ;; Atomically sets cursor up to blink. Cursor may be #f, in which
;; case blinking will pause.
(without-interruption
(lambda ()
(define-syntax %trace
(syntax-rules ()
- ((_ ARGS ...) (if %trace? (outf-error ARGS ...)))))
+ ((_ args ...) (if %trace? (outf-error args ...)))))
(define %trace2? #f)
(define-syntax %trace2
(syntax-rules ()
- ((_ ARGS ...) (if %trace2? (outf-error ARGS ...)))))
+ ((_ args ...) (if %trace2? (outf-error args ...)))))
(define %trace-buttons? #f)
(define-syntax %trace-buttons
(syntax-rules ()
- ((_ ARGS ...) (if %trace-buttons? (%%trace-buttons ARGS ...)))))
+ ((_ args ...) (if %trace-buttons? (%%trace-buttons args ...)))))
(define (%%trace-buttons . msg)
(apply outf-error `("; Button ",@msg"\n")))
Load the Gtk-Screen option. |#
-(load-option 'Edwin)
-(load-option 'Gtk)
+(load-option 'edwin)
+(load-option 'gtk)
(with-loader-base-uri (system-library-uri "gtk-screen/")
(lambda ()
(load-package-set "gtk-screen")))
#| -*-Scheme-*- |#
-(define-load-option 'GTK-SCREEN
+(define-load-option 'gtk-screen
(let ((pathname
(merge-pathnames "make"
(directory-pathname (current-load-pathname)))))
(begin
(parameterize ((param:suppress-loading-message? #t))
- (load-option 'CREF)
- (load-option 'CAIRO)
- (load-option 'FFI))
+ (for-each load-option '(cref cairo ffi)))
(if (name->package '(GTK))
(error "The GTK package already exists."))
: ${MIT_SCHEME_EXE=mit-scheme}
${MIT_SCHEME_EXE} --prepend-library . <<\EOF
(begin
- (load-option 'GTK)
- (let ((new (extend-top-level-environment (->environment '(GTK))))
+ (load-option 'gtk)
+ (let ((new (extend-top-level-environment (->environment '(gtk))))
(ffi (->environment '(RUNTIME FFI))))
(load "gtk-tests" new)
(if (gtk-initialized?)
@end ifhtml
re-written to use the Gtk system. Notice that the program does not
need the FFI; it uses no FFI syntax. There is no need to
-@code{(load-option 'FFI)}.
+@code{(load-option 'ffi)}.
@verbatiminclude hello.scm
@example
mit-scheme
- (load-option 'Gtk)
+ (load-option 'gtk)
(ge '(gtk))
(load "hello")
(hello)
@example
mit-scheme
- (load-option 'Gtk)
+ (load-option 'gtk)
(make-gtk-event-viewer-demo)
@end example
@example
mit-scheme
- (load-option 'Gtk)
+ (load-option 'gtk)
(make-fix-layout-demo)
@end example
@example
mit-scheme-pucked
- (load-option 'Gtk)
+ (load-option 'gtk)
(make-pole-zero)
@end example
Load the Gtk option. |#
-(load-option 'CAIRO)
-(load-option 'FFI) ; Referenced in gtk.pkg.
+(load-option 'cairo)
+(load-option 'ffi) ; Referenced in gtk.pkg.
(with-loader-base-uri (system-library-uri "gtk/")
(lambda ()
(load-package-set "gtk")))
#| -*-Scheme-*- |#
-(define-load-option 'GTK
+(define-load-option 'gtk
(let ((pathname
(merge-pathnames "make"
(directory-pathname (current-load-pathname)))))
(loop skipping?))))))
(parameterize ((param:suppress-loading-message? #t))
- (load-option 'FFI))
+ (load-option 'ffi))
((access rewrite-file (->environment '(ffi build)))
(merge-pathnames "TAGS")
rewriter)))
;;;; Test gfile port performance.
\f
-(load-option 'Gtk)
+(load-option 'gtk)
;; The number of trials for each test.
(define repeats 7)
#| -*-Scheme-*- |#
-;;;; Compile the MCRYPT option.
+;;;; Compile the Mcrypt option.
(for-each load-option '(cref ffi))
|#
-;;;; Test the MCRYPT option.
+;;;; Test the Mcrypt option.
(define (random-string length)
(list->string (make-initialized-list length
#| -*-Scheme-*- |#
-(define-load-option 'MCRYPT
+(define-load-option 'mcrypt
(standard-system-loader "."))
(further-load-options #t)
\ No newline at end of file
(loop scms chs cdecls (cons section rest))))))))))
(parameterize ((param:suppress-loading-message? #t))
- (load-option 'FFI))
+ (load-option 'ffi))
((access rewrite-file (->environment '(ffi build)))
(merge-pathnames "TAGS")
rewriter)))
(begin
(parameterize ((param:suppress-loading-message? #t))
- (load-option 'CREF)
- (load-option 'GLIB)
- (load-option 'FFI))
+ (for-each load-option '(cref glib ffi)))
- (if (name->package '(PANGO))
+ (if (name->package '(pango))
(error "The PANGO package already exists."))
(let ((package-set (package-set-pathname "pango")))
(if (not (file-modification-time<? "pango.pkg" package-set))
Load the Pango option. |#
-(load-option 'GLIB)
+(load-option 'glib)
(with-loader-base-uri (system-library-uri "pango/")
(lambda ()
(load-package-set "pango")))
#| -*-Scheme-*- |#
-(define-load-option 'PANGO
+(define-load-option 'pango
(let ((pathname
(merge-pathnames "make"
(directory-pathname (current-load-pathname)))))
#!/bin/sh
# -*-Scheme-*-
#
-# Test the PANGO option.
+# Test the Pango option.
set -e
: ${MIT_SCHEME_EXE=mit-scheme}
${MIT_SCHEME_EXE} --prepend-library . <<\EOF
-(load-option 'PANGO)
+(load-option 'pango)
EOF
(define-syntax error-if-null
(syntax-rules ()
- ((_ ALIEN MESSAGE ...)
- (if (alien-null? ALIEN)
- (error MESSAGE ...)))))
+ ((_ alien message ...)
+ (if (alien-null? alien)
+ (error message ...)))))
(define (color? object)
(and (flo:flonum? object) (fix:= 4 (flo:vector-length object))))
(define (->color spec operator)
(assert-glib-locked '->color)
(cond ((color? spec) spec)
- ((eq? spec 'WHITE) white)
- ((eq? spec 'BLACK) black)
+ ((eq? spec 'white) white)
+ ((eq? spec 'black) black)
((symbol? spec) (pango-color-parse (symbol->string spec)))
((string? spec) (pango-color-parse spec))
(else
(gobject-alien layout)))
(define (pango-layout-set-font-description layout font)
- ;; The toolkit makes a copy of FONT.
+ ;; The toolkit makes a copy of font.
(guarantee-pango-font-description font 'pango-layout-set-font-description)
(assert-glib-locked 'pango-layout-set-font-description)
(C-call "pango_layout_set_font_description"
(make-alien '|PangoFontDescription|) context))
(define (pango-context-set-font-description context font)
- ;; FONT is still owned by Scheme. The toolkit makes a copy.
+ ;; Font is still owned by Scheme. The toolkit makes a copy.
(guarantee-pango-context context 'pango-context-set-font-description)
(guarantee-pango-font-description font 'pango-context-set-font-description)
(assert-glib-locked 'pango-context-set-font-description)
(loop skipping?))))))
(parameterize ((param:suppress-loading-message? #t))
- (load-option 'FFI))
+ (load-option 'ffi))
((access rewrite-file (->environment '(ffi build)))
(merge-pathnames "TAGS")
rewriter)))
#| -*-Scheme-*- |#
-(define-load-option 'PGSQL
+(define-load-option 'pgsql
(standard-system-loader "."))
(further-load-options #t)
\ No newline at end of file
set -e
${MIT_SCHEME_EXE} --prepend-library . <<\EOF
-(load-option 'PGSQL)
+(load-option 'pgsql)
(load "pgsql-check" (->environment '(postgresql)))
EOF
(lambda (form environment)
environment
(if (syntax-match? '(identifier * identifier) (cdr form))
- `(BEGIN
+ `(begin
,@(let loop ((names (cddr form)) (index 0))
(if (pair? names)
- `((DEFINE ,(car names) ,index)
+ `((define ,(car names) ,index)
,@(loop (cdr names) (+ index 1)))
'()))
- (DEFINE ,(cadr form) '#(,@(cddr form))))
+ (define ,(cadr form) '#(,@(cddr form))))
(ill-formed-syntax form)))))
(define (index->name index enum)
- (guarantee index-fixnum? index 'INDEX->NAME)
+ (guarantee index-fixnum? index 'index->name)
(if (not (fix:< index (vector-length enum)))
- (error:bad-range-argument index 'INDEX->NAME))
+ (error:bad-range-argument index 'index->name))
(vector-ref enum index))
(define-enum connection-status
- PGSQL-CONNECTION-OK
- PGSQL-CONNECTION-BAD
- PGSQL-CONNECTION-STARTED
- PGSQL-CONNECTION-MADE
- PGSQL-CONNECTION-AWAITING-RESPONSE
- PGSQL-CONNECTION-AUTH-OK
- PGSQL-CONNECTION-SETENV)
+ pgsql-connection-ok
+ pgsql-connection-bad
+ pgsql-connection-started
+ pgsql-connection-made
+ pgsql-connection-awaiting-response
+ pgsql-connection-auth-ok
+ pgsql-connection-setenv)
(define-enum postgres-polling-status
- PGSQL-POLLING-FAILED
- PGSQL-POLLING-READING
- PGSQL-POLLING-WRITING
- PGSQL-POLLING-OK
- PGSQL-POLLING-ACTIVE)
+ pgsql-polling-failed
+ pgsql-polling-reading
+ pgsql-polling-writing
+ pgsql-polling-ok
+ pgsql-polling-active)
(define-enum exec-status
- PGSQL-EMPTY-QUERY
- PGSQL-COMMAND-OK
- PGSQL-TUPLES-OK
- PGSQL-COPY-OUT
- PGSQL-COPY-IN
- PGSQL-BAD-RESPONSE
- PGSQL-NONFATAL-ERROR
- PGSQL-FATAL-ERROR)
+ pgsql-empty-query
+ pgsql-command-ok
+ pgsql-tuples-ok
+ pgsql-copy-out
+ pgsql-copy-in
+ pgsql-bad-response
+ pgsql-nonfatal-error
+ pgsql-fatal-error)
\f
(define pgsql-initialized? #f)
(define connections)
(if (syntax-match? '(symbol expression) (cdr form))
(let ((type (cadr form)))
(let ((type? (symbol type '?))
- (guarantee-type (symbol 'GUARANTEE- type))
- (error:not-type (symbol 'ERROR:NOT- type))
- (guarantee-valid-type (symbol 'GUARANTEE-VALID- type))
- (type-handle (symbol type '-HANDLE)))
- `(BEGIN
- (DEFINE-INTEGRABLE (,guarantee-type OBJECT CALLER)
- (IF (NOT (,type? OBJECT))
- (,error:not-type OBJECT CALLER)))
- (DEFINE (,error:not-type OBJECT CALLER)
- (ERROR:WRONG-TYPE-ARGUMENT OBJECT ,(caddr form) CALLER))
- (DEFINE-INTEGRABLE (,guarantee-valid-type OBJECT CALLER)
- (IF (AND (,type? OBJECT) (,type-handle OBJECT))
- (,type-handle OBJECT)
- (,error:not-type OBJECT CALLER))))))
+ (guarantee-type (symbol 'guarantee- type))
+ (error:not-type (symbol 'error:not- type))
+ (guarantee-valid-type (symbol 'guarantee-valid- type))
+ (type-handle (symbol type '-handle)))
+ `(begin
+ (define-integrable (,guarantee-type object caller)
+ (if (not (,type? object))
+ (,error:not-type object caller)))
+ (define (,error:not-type object caller)
+ (error:wrong-type-argument object ,(caddr form) caller))
+ (define-integrable (,guarantee-valid-type object caller)
+ (if (and (,type? object) (,type-handle object))
+ (,type-handle object)
+ (,error:not-type object caller))))))
(ill-formed-syntax form)))))
(define-guarantee connection "PostgreSQL connection")
(set! pgsql-initialized? #t))))
\f
(define condition-type:pgsql-error
- (make-condition-type 'PGSQL-ERROR condition-type:error '()
+ (make-condition-type 'pgsql-error condition-type:error '()
(lambda (condition port)
condition
(write-string "Unknown PostgreSQL error." port))))
(define condition-type:pgsql-connection-error
- (make-condition-type 'PGSQL-CONNECTION-ERROR condition-type:pgsql-error
- '(MESSAGE)
+ (make-condition-type 'pgsql-connection-error condition-type:pgsql-error
+ '(message)
(lambda (condition port)
(write-string "Unable to connect to PostgreSQL server" port)
- (write-message (access-condition condition 'MESSAGE) port))))
+ (write-message (access-condition condition 'message) port))))
(define error:pgsql-connection
(condition-signaller condition-type:pgsql-connection-error
- '(MESSAGE)
+ '(message)
standard-error-handler))
(define condition-type:pgsql-query-error
- (make-condition-type 'PGSQL-QUERY-ERROR condition-type:pgsql-error
- '(QUERY RESULT)
+ (make-condition-type 'pgsql-query-error condition-type:pgsql-error
+ '(query result)
(lambda (condition port)
(write-string "PostgreSQL query error" port)
(write-message
- (pgsql-result-error-message (access-condition condition 'RESULT))
+ (pgsql-result-error-message (access-condition condition 'result))
port))))
(define error:pgsql-query
(condition-signaller condition-type:pgsql-query-error
- '(QUERY RESULT)
+ '(query result)
standard-error-handler))
(define (write-message string port)
(lambda (handle)
(cond ((alien-null? handle)
(error:pgsql-connection #f))
- ((= PGSQL-CONNECTION-BAD (pq-status handle))
+ ((= pgsql-connection-bad (pq-status handle))
(let ((msg (pq-error-message handle)))
(pq-finish handle)
(error:pgsql-connection msg))))
unspecific))))
(define (pgsql-conn-open? connection)
- (guarantee-connection connection 'PGSQL-CONN-OPEN?)
+ (guarantee-connection connection 'pgsql-conn-open?)
(if (connection-handle connection) #t #f))
(define-integrable (connection->handle connection)
- (guarantee-valid-connection connection 'CONNECTION->HANDLE))
+ (guarantee-valid-connection connection 'connection->handle))
(define (poll-pgsql-conn connection)
(index->name (pq-connect-poll (connection->handle connection))
environment
(if (syntax-match? '(symbol) (cdr form))
(let ((field (cadr form)))
- `(DEFINE (,(symbol 'PGSQL-CONN- field) OBJECT)
- (,(symbol 'PQ- field) (CONNECTION->HANDLE OBJECT))))
+ `(define (,(symbol 'pgsql-conn- field) object)
+ (,(symbol 'pq- field) (connection->handle object))))
(ill-formed-syntax form)))))
(define-connection-accessor db)
(pq-unescape-bytea string))
\f
(define (exec-pgsql-query connection query)
- (guarantee string? query 'EXEC-PGSQL-QUERY)
+ (guarantee string? query 'exec-pgsql-query)
(let ((result
(let ((handle (connection->handle connection)))
(make-gc-finalized-object
(error "Unable to execute PostgreSQL query:" query))
(make-result result-handle))))))
(if (not (memq (pgsql-result-status result)
- '(PGSQL-COMMAND-OK
- PGSQL-TUPLES-OK
- PGSQL-COPY-OUT
- PGSQL-COPY-IN)))
+ '(pgsql-command-ok
+ pgsql-tuples-ok
+ pgsql-copy-out
+ pgsql-copy-in)))
(error:pgsql-query query result))
result))
environment
(if (syntax-match? '(symbol) (cdr form))
(let* ((field (cadr form))
- (operator (symbol 'PGSQL- field)))
- `(DEFINE (,operator OBJECT)
- (,(symbol 'PQ- field) (RESULT->HANDLE OBJECT ',operator))))
+ (operator (symbol 'pgsql- field)))
+ `(define (,operator object)
+ (,(symbol 'pq- field) (result->handle object ',operator))))
(ill-formed-syntax form)))))
(define-result-accessor result-error-message)
(loop scms chs cdecls (cons section rest))))))))))
(parameterize ((param:suppress-loading-message? #t))
- (load-option 'FFI))
+ (load-option 'ffi))
((access rewrite-file (->environment '(ffi build)))
(merge-pathnames "TAGS")
rewriter)))
To use:
- (load-option 'PLANETARIUM)
+ (load-option 'planetarium)
(make-tellurion)
A tellurion should pop up in a new window on your desktop.
# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA
# 02110-1301, USA.
-# Test the PLANETARIUM option.
+# Test the Planetarium option.
set -ex
: ${MIT_SCHEME_EXE=mit-scheme}
(begin
(set! *initial-options-file* (merge-pathnames "mit-optiondb.scm"))
- (load-option 'PLANETARIUM)
+ (load-option 'planetarium)
(if (not (gtk-initialized?))
(warn "Could not test the planetarium.")
(load file (->environment pkg-name)))
(parameterize ((param:suppress-loading-message? #t))
- (load-option 'CREF)
- (load-option 'GTK))
+ (load-option 'cref)
+ (load-option 'gtk))
- (if (name->package '(PLANETARIUM))
- (error "The PLANETARIUM package already exists."))
+ (if (name->package '(planetarium))
+ (error "The planetarium package already exists."))
(let ((package-set (package-set-pathname "mit")))
(if (not (file-modification-time<? "mit.pkg" package-set))
(cref/generate-trivial-constructor "mit"))
(if (not (warn-errors?
(lambda ()
(parameterize ((param:suppress-loading-message? #t))
- (load-option 'GL)))))
+ (load-option 'gl)))))
(begin
(let ((package-set (package-set-pathname "mit-3d")))
(if (not (file-modification-time<? "mit-3d.pkg" package-set))
;;;; Link a graphics type into the (planetarium) package.
-(warn-errors? (lambda () (load-option 'GTK)))
+(warn-errors? (lambda () (load-option 'gtk)))
(let ((planet (->environment '(planetarium)))
(graphics (cond ((graphics-type-available? 'gtk)
(->environment '(planetarium gtk-graphics)))
|#
-;;;; Load the PLANETARIUM plugin.
+;;;; Load the Planetarium plugin.
;;; Check for a GL option and load the 3D parts of the Planetarium
;;; when it is available. (This presumes the 3D portion was
(parameterize ((param:suppress-loading-message? #t))
(load-package-set "mit")
(load "mit-link")
- (if (not (warn-errors? (lambda () (load-option 'GL))))
+ (if (not (warn-errors? (lambda () (load-option 'gl))))
(load-package-set "mit-3d")))))
(add-subsystem-identification! "Planetarium" '(0 8))
\ No newline at end of file
;;;; Test optiondb, includes the installed system's optiondb.
-(define-load-option 'PLANETARIUM
+(define-load-option 'planetarium
(let ((pathname
(merge-pathnames "mit-make"
(directory-pathname (current-load-pathname)))))
(define-syntax essential-if
(syntax-rules ()
- ((_ PRED CONS ALT)
- (IF PRED CONS ALT))))
+ ((_ pred cons alt)
+ (if pred cons alt))))
(define-syntax essential-let
(syntax-rules ()
((_ (bindings ...) body ...)
- (LET (bindings ...) body ...))))
+ (let (bindings ...) body ...))))
(define-integrable (essential-* a b)
(* a b))
(string-append a b))
(define (r3rs-number->string number format)
- (cond ((and (equal? format '(INT))
+ (cond ((and (equal? format '(int))
(integer? number))
(number->string number))
- ((and (eq? (car format) 'FIX)
+ ((and (eq? (car format) 'fix)
(integer? (cadr format))
(null? (cddr format)))
(let* ((whole (truncate->exact number))
(define-syntax r3rs-atan
(syntax-rules ()
- ((_ t) (ATAN t))
- ((_ y x) (ATAN2 y x))))
\ No newline at end of file
+ ((_ t) (atan t))
+ ((_ y x) (atan2 y x))))
\ No newline at end of file
;;;; Generate snapshots (PNG files).
;; Expect warning about DISPLAY not set.
-(load-option 'CAIRO)
+(load-option 'cairo)
(with-working-directory-pathname
(directory-pathname (current-load-pathname))
(rsc-macro-transformer
(lambda (form environment)
(declare (ignore environment))
- (if (syntax-match? '((IDENTIFIER . MIT-BVL) + FORM) (cdr form))
- `(BEGIN
- (DECLARE (INTEGRATE-OPERATOR ,(caadr form)))
- (DEFINE ,@(cdr form)))
+ (if (syntax-match? '((identifier . mit-bvl) + form) (cdr form))
+ `(begin
+ (declare (integrate-operator ,(caadr form)))
+ (define ,@(cdr form)))
(ill-formed-syntax form)))))
(define-syntax cil-file
(define (read-cil-file name)
(let ((in (open-input-file name)))
- (port/set-line-ending in 'CRLF)
+ (port/set-line-ending in 'crlf)
(let loop ((points '()) (lines '()))
(let ((line (read-line in)))
(if (eof-object? line)
(define (ecliptical->equatorial! lat/long obliquity)
;; 13.3-4: "Transformation from ecliptical into equatorial
- ;; coordinates" (all in degrees) with a given OBLIQUITY.
+ ;; coordinates" (all in degrees) with a given obliquity.
(let ((lambd* (degrees->radians (longitude lat/long)))
(beta (degrees->radians (latitude lat/long)))
(epsilon (degrees->radians obliquity)))
unspecific)
(define (tellurion command . args)
- (cond ((eq? command 'TURN-TO)
+ (cond ((eq? command 'turn-to)
(let ((lat (->flonum (car args)))
(long (->flonum (cadr args))))
(if (or (< lat -90) (< 90 lat))
(if (or (< long -180) (< 180 long))
(error "Invalid longitude:" long))
(queue! 'turn-to lat long)))
- ((eq? command 'TIME-TO)
+ ((eq? command 'time-to)
(queue! 'time-to (->time (car args))))
- ((eq? command 'HOUR-TO)
+ ((eq? command 'hour-to)
(let ((hour (car args)))
(guarantee integer? hour 'hour-to)
(if (or (< hour 0) (< 23 hour))
(error "Invalid hour:" hour))
(queue! 'hour-to hour)))
- ((eq? command 'STOP)
+ ((eq? command 'stop)
(queue! queue 'stop))
- ((eq? command 'GO)
+ ((eq? command 'go)
(queue! queue 'go))
(else (error "unknown command:" command args))))
((integer? object)
object)
(else
- (error "Not a time (universal, decoded or 'CURRENT):" object))))
+ (error "Not a time (universal, decoded or 'current):" object))))
(define (run-tellurion queue)
(let ((device (make-suitable-graphics-device))
(if (not (eq? time 'current))
(set! time (+ time (* 15 60))))
(draw))
- ((eq? (car command) 'TURN-TO)
+ ((eq? (car command) 'turn-to)
(set-latitude! lat/lng (cadr command))
(set-longitude! lat/lng (caddr command))
(draw))
- ((eq? (car command) 'TIME-TO)
+ ((eq? (car command) 'time-to)
(set! time (cadr command))
(draw))
- ((eq? (car command) 'STOP)
+ ((eq? (car command) 'stop)
(set! stopped? #t))
- ((eq? (car command) 'GO)
+ ((eq? (car command) 'go)
(set! stopped? #f)
(if (eq? time 'current)
(draw)))))
(define (check-flonum-args num description)
(if (not (= num (guarantee-list-of-type->length
- args real? "a real number" 'TERRAIN)))
+ args real? "a real number" 'terrain)))
(error (string-append
"The "(symbol-name command)" command requires "
(number->string num '(int))" arguments: "description"."))))
(cond
- ((eq? 'POSITION command)
- (check-flonum-args 3 "LATITUDE, LONGITUDE and ALTITUDE")
+ ((eq? 'position command)
+ (check-flonum-args 3 "latitude, longitude and altitude")
(let ((lat (->flonum (car args)))
(lng (->flonum (cadr args)))
(alt (->flonum (caddr args))))
(set-z! pos (flo:* m/d (flo:- (latitude origin) lat)))))
(gtk-widget-queue-draw widget))
- ((eq? 'HEADING command)
- (check-flonum-args 1 "AZIMUTH")
+ ((eq? 'heading command)
+ (check-flonum-args 1 "azimuth")
(set-glx-viewport-heading! widget
(degrees->radians (->flonum (car args))))
(gtk-widget-queue-draw widget))
- ((eq? 'TILT command)
- (check-flonum-args 1 "INCLINATION in degrees")
+ ((eq? 'tilt command)
+ (check-flonum-args 1 "inclination in degrees")
(if (not (flo:<= (flo:abs (->flonum (car args))) 80.))
(error "Requested inclination greater than 80°.")
(set-glx-viewport-tilt! widget (degrees->radians (car args))))
(gtk-widget-queue-draw widget))
(else
- (error:wrong-type-argument command "a command name" 'TERRAIN))))))
+ (error:wrong-type-argument command "a command name" 'terrain))))))
(define (%make-terrain options)
(width height)))
(<glx-viewport>)
- ;; MATRIX should contain metric height information per latitude/
- ;; longitude. MATRIX[0,0] would be the height in meters at ORIGIN,
+ ;; Matrix should contain metric height information per latitude/
+ ;; longitude. MATRIX[0,0] would be the height in meters at origin,
;; a latitude/longitude. MATRIX[0,1] is the height at a position
- ;; STEP-DEGREES due East. MATRIX[1,0] is the height STEP-DEGREES
+ ;; step-degrees due East. MATRIX[1,0] is the height step-degrees
;; North.
(matrix define accessor)
(rows define accessor)
;; latitudes are small and/or do not vary greatly.
(step-meters define standard)
- ;; Update LIGHT0 if changing this:
+ ;; Update light0 if changing this:
(light-position define accessor
initializer (lambda () (flo:4d 1. 1. 1. 0.)))
(call-next-method widget)
(with-glx-widget widget
(lambda ()
- (gl:shade-model 'SMOOTH) ; Enable Smooth Shading
- ;;(gl:shade-model 'FLAT)
+ (gl:shade-model 'smooth) ; Enable Smooth Shading
+ ;;(gl:shade-model 'flat)
(gl:clear-color (color .527 .805 .977 1.)) ; light sky blue: #x87cefa
- (gl:enable 'DEPTH-TEST)
- ;;(gl:enable 'CULL-FACE)
+ (gl:enable 'depth-test)
+ ;;(gl:enable 'cull-face)
;; Really Nice Perspective Calculations
- (gl:hint 'PERSPECTIVE-CORRECTION 'NICEST)
+ (gl:hint 'perspective-correction 'nicest)
- (gl:light-model 'LOCAL-VIEWER 1.)
- (gl:enable 'LIGHTING)
- (gl:enable 'LIGHT0)
+ (gl:light-model 'local-viewer 1.)
+ (gl:enable 'lighting)
+ (gl:enable 'light0)
(if (terrain-viewport-color-function widget)
(begin
- (gl:color-material 'FRONT 'DIFFUSE)
- (gl:enable 'COLOR-MATERIAL)))
+ (gl:color-material 'front 'diffuse)
+ (gl:enable 'color-material)))
(let ((mesh (gl:gen-lists 1)))
- (gl:new-list mesh 'COMPILE)
+ (gl:new-list mesh 'compile)
(draw-mesh widget)
(gl:end-list)
(set-terrain-viewport-mesh! widget mesh))))
(define-method glx-viewport-draw ((widget <terrain-viewport>))
(%trace2 "; (glx-viewport-draw <terrain-viewport>)\n")
- (gl:light 'LIGHT0 'POSITION (terrain-viewport-light-position widget))
+ (gl:light 'light0 'position (terrain-viewport-light-position widget))
(gl:call-list (terrain-viewport-mesh widget))
(update-label widget))
(let ((rows (terrain-viewport-rows widget))
(columns (terrain-viewport-columns widget))
(step (terrain-viewport-step-meters widget)))
- (%trace "; disabling LIGHTING\n")
- (gl:disable 'LIGHTING)
- (%trace "; enabling BLEND\n")
- (gl:enable 'BLEND)
- (%trace "; setting BLEND-FUNC\n")
- (gl:blend-func 'SRC-ALPHA 'ONE-MINUS-SRC-ALPHA)
- (%trace "; setting COLOR\n")
+ (%trace "; disabling lighting\n")
+ (gl:disable 'lighting)
+ (%trace "; enabling blend\n")
+ (gl:enable 'blend)
+ (%trace "; setting blend-func\n")
+ (gl:blend-func 'src-alpha 'one-minus-src-alpha)
+ (%trace "; setting color\n")
(gl:color (flo:4d 0. 0. 1. .1))
- (%trace "; setting NORMAL\n")
+ (%trace "; setting normal\n")
(gl:normal (flo:3d 0. 1. 0.))
- (%trace "; beginning QUADS\n")
- (gl:begin 'QUADS)
+ (%trace "; beginning quads\n")
+ (gl:begin 'quads)
(let ((max-x (flo:* (flo:- (->flonum columns) 1.) step))
(min-z (flo:* (flo:- 1. (->flonum rows)) step)))
(gl:vertex (flo:3d 0. 0. 0.))
(gl:vertex (flo:3d max-x 0. 0.))
(gl:vertex (flo:3d max-x 0. min-z))
(gl:vertex (flo:3d 0. 0. min-z)))
- (%trace "; ending QUADS\n")
+ (%trace "; ending quads\n")
(gl:end)
- (%trace "; disabling BLEND\n")
- (gl:disable 'BLEND)
- (%trace "; enabling LIGHTING\n")
- (gl:enable 'LIGHTING)))
+ (%trace "; disabling blend\n")
+ (gl:disable 'blend)
+ (%trace "; enabling lighting\n")
+ (gl:enable 'lighting)))
(define (draw-mesh widget)
(%trace "; draw-mesh "widget"\n")
(flo:* (->flonum y) -step)))))
(%trace "; begin quads\n")
- (gl:begin 'QUADS) ; or LINES for wireframe
+ (gl:begin 'quads) ; or 'lines for wireframe
(let ((last-row (fix:- rows 1))
(last-column (fix:- columns 1)))
(do ((y 0 (fix:1+ y)))
(define-syntax %trace
(syntax-rules ()
- ((_ . MSG)
- (if %trace? ((lambda () (outf-error . MSG)))))))
+ ((_ . msg)
+ (if %trace? ((lambda () (outf-error . msg)))))))
(define %trace2? #f)
(define-syntax %trace2
(syntax-rules ()
- ((_ . MSG)
- (if %trace2? ((lambda () (outf-error . MSG)))))))
\ No newline at end of file
+ ((_ . msg)
+ (if %trace2? ((lambda () (outf-error . msg)))))))
\ No newline at end of file
-The X11-SCREEN option.
+The X11 Screen option.
This option creates an (edwin screen x11-screen) package that is
autoloaded by Edwin's X display type. It is built in the GNU standard
#| -*-Scheme-*- |#
-(define-load-option 'X11-SCREEN
+(define-load-option 'x11-screen
(standard-system-loader "."))
(further-load-options #t)
\ No newline at end of file
(sc-macro-transformer
(lambda (form environment)
(let ((name (cadr form)))
- `(DEFINE ,(symbol 'EDWIN-COMMAND$X- name)
- ,(close-syntax (symbol 'EDWIN-COMMAND$ name)
+ `(define ,(symbol 'edwin-command$x- name)
+ ,(close-syntax (symbol 'edwin-command$ name)
environment))))))
(define-old-mouse-command set-foreground-color)
#!/bin/sh
# -*-Scheme-*-
#
-# Test the X11-SCREEN option.
+# Test the X11 Screen option.
set -e
${MIT_SCHEME_EXE} --prepend-library . <<\EOF
(display "WM allowed actions:\n")
(pp (vector-map
(lambda (atom) (x-atom->symbol xd atom))
- (get-xterm-property xterm '_NET_WM_ALLOWED_ACTIONS 'atom #f)))
+ (get-xterm-property xterm '_net_wm_allowed_actions 'atom #f)))
(display "WM hints:\n")
- (pp (get-xterm-property xterm 'WM_HINTS 'wm_hints #f))
+ (pp (get-xterm-property xterm 'wm_hints 'wm_hints #f))
(display "WM normal hints:\n")
- (pp (get-xterm-property xterm 'WM_NORMAL_HINTS 'wm_size_hints #f))))
\ No newline at end of file
+ (pp (get-xterm-property xterm 'wm_normal_hints 'wm_size_hints #f))))
\ No newline at end of file
(selected? #t)
(name #f)
(icon-name #f)
- (x-visibility 'VISIBLE)
+ (x-visibility 'visible)
(mapped? #f)
(unexposed? #t))
;;; on the window until the first Expose event arrives. The manual
;;; says nothing about the relationship between this event and the
;;; MapNotify event associated with that mapping. We use the fields
-;;; UNEXPOSED? and MAPPED? to track the arrival of those events.
-;;; The screen's visibility remains 'UNMAPPED until both have arrived.
-;;; Meanwhile, X-VISIBILITY tracks Visibility events. When the window
-;;; is both exposed and mapped, VISIBILITY reflects X-VISIBILITY.
+;;; unexposed? and mapped? to track the arrival of those events.
+;;; The screen's visibility remains 'unmapped until both have arrived.
+;;; Meanwhile, x-visibility tracks Visibility events. When the window
+;;; is both exposed and mapped, visibility reflects x-visibility.
(define (screen-x-visibility screen)
(xterm-screen-state/x-visibility (screen-state screen)))
(begin
(set-screen-unexposed?! screen #f)
(update-visibility! screen)
- (if (eq? 'ENTERED unexposed?)
+ (if (eq? 'entered unexposed?)
(xterm-screen/enter! screen))))))))
(define (update-visibility! screen)
(if (and (screen-mapped? screen)
(screen-exposed? screen))
(screen-x-visibility screen)
- 'UNMAPPED))))
+ 'unmapped))))
\f
(define (screen-xterm screen)
(xterm-screen-state/xterm (screen-state screen)))
(define (xterm-screen/enter! screen)
(if (screen-unexposed? screen)
- (set-screen-unexposed?! screen 'ENTERED)
+ (set-screen-unexposed?! screen 'entered)
(begin
(set-screen-selected?! screen #t)
(let ((xterm (screen-xterm screen)))
(define (xterm-screen/scroll-lines-down! screen xl xu yl yu amount)
(xterm-scroll-lines-down (screen-xterm screen) xl xu yl yu amount)
- 'UNCHANGED)
+ 'unchanged)
(define (xterm-screen/scroll-lines-up! screen xl xu yl yu amount)
(xterm-scroll-lines-up (screen-xterm screen) xl xu yl yu amount)
- 'UNCHANGED)
+ 'unchanged)
(define (xterm-screen/beep screen)
(x-window-beep (screen-xterm screen))
(process-special-event event))))
(pce-event
(lambda (flag)
- (make-input-event (if (eq? flag 'FORCE-RETURN) 'RETURN 'UPDATE)
+ (make-input-event (if (eq? flag 'force-return) 'return 'update)
update-screens!
#f))))
(let ((get-next-event
(define (register!)
(set! previewer-registration
(register-io-thread-event (x-display-descriptor x-display-data)
- 'READ (current-thread) preview-events))
+ 'read (current-thread) preview-events))
unspecific)
(define (preview-events mode)
(define-event-handler event-type:button-down
(lambda (screen event)
(set! last-focus-time (vector-ref event 5))
- (if (eq? ignore-button-state 'IGNORE-BUTTON-DOWN)
+ (if (eq? ignore-button-state 'ignore-button-down)
(begin
- (set! ignore-button-state 'IGNORE-BUTTON-UP)
+ (set! ignore-button-state 'ignore-button-up)
#f)
(let ((xterm (screen-xterm screen)))
(make-input-event
- 'BUTTON
+ 'button
execute-button-command
screen
(let ((n (vector-ref event 4)))
- (make-down-button (fix:and n #x0FF)
- (fix:lsh (fix:and n #xF00) -8)))
+ (make-down-button (fix:and n #x0ff)
+ (fix:lsh (fix:and n #xf00) -8)))
(xterm-map-x-coordinate xterm (vector-ref event 2))
(xterm-map-y-coordinate xterm (vector-ref event 3)))))))
(define-event-handler event-type:button-up
(lambda (screen event)
(set! last-focus-time (vector-ref event 5))
- (if (eq? ignore-button-state 'IGNORE-BUTTON-UP)
+ (if (eq? ignore-button-state 'ignore-button-up)
(begin
(set! ignore-button-state #f)
#f)
(let ((xterm (screen-xterm screen)))
(make-input-event
- 'BUTTON
+ 'button
execute-button-command
screen
(let ((n (vector-ref event 4)))
- (make-up-button (fix:and n #x0FF)
+ (make-up-button (fix:and n #x0ff)
(fix:lsh (fix:and n #xF00) -8)))
(xterm-map-x-coordinate xterm (vector-ref event 2))
(xterm-map-y-coordinate xterm (vector-ref event 3)))))))
\f
(define-event-handler event-type:configure
(lambda (screen event)
- (make-input-event 'SET-SCREEN-SIZE
+ (make-input-event 'set-screen-size
(lambda (screen event)
(let ((xterm (screen-xterm screen))
(x-size (vector-ref event 2))
(lambda (screen event)
event
(if x-screen-ignore-focus-button?
- (set! ignore-button-state 'IGNORE-BUTTON-DOWN))
+ (set! ignore-button-state 'ignore-button-down))
(and (not (selected-screen? screen))
- (make-input-event 'SELECT-SCREEN
+ (make-input-event 'select-screen
(lambda (screen)
(fluid-let ((last-focus-time #f))
(select-screen screen)))
(lambda (screen event)
event
(and (not (screen-deleted? screen))
- (make-input-event 'DELETE-SCREEN delete-screen! screen))))
+ (make-input-event 'delete-screen delete-screen! screen))))
;; Note that this handler is run in an interrupt (IO event).
(define-event-handler event-type:map
(begin
(set-screen-mapped?! screen #t)
(screen-force-update screen)
- (make-input-event 'UPDATE update-screen! screen #f)))))
+ (make-input-event 'update update-screen! screen #f)))))
;; Note that this handler is run in an interrupt (IO event).
(define-event-handler event-type:unmap
(and (not (screen-deleted? screen))
(let ((old-visibility (screen-x-visibility screen)))
(case (vector-ref event 2)
- ((0) (set-screen-x-visibility! screen 'VISIBLE))
- ((1) (set-screen-x-visibility! screen 'PARTIALLY-OBSCURED))
- ((2) (set-screen-x-visibility! screen 'OBSCURED)))
- (and (eq? old-visibility 'OBSCURED)
+ ((0) (set-screen-x-visibility! screen 'visible))
+ ((1) (set-screen-x-visibility! screen 'partially-obscured))
+ ((2) (set-screen-x-visibility! screen 'obscured)))
+ (and (eq? old-visibility 'obscured)
(begin
(screen-force-update screen)
- (make-input-event 'UPDATE update-screen! screen #f)))))))
+ (make-input-event 'update update-screen! screen #f)))))))
(define-event-handler event-type:take-focus
(lambda (screen event)
(set! last-focus-time (vector-ref event 2))
- (make-input-event 'SELECT-SCREEN select-screen screen)))
+ (make-input-event 'select-screen select-screen screen)))
\f
;;;; Atoms
(define built-in-atoms
'#(#F
- PRIMARY
- SECONDARY
- ARC
- ATOM
- BITMAP
- CARDINAL
- COLORMAP
- CURSOR
- CUT_BUFFER0
- CUT_BUFFER1
- CUT_BUFFER2
- CUT_BUFFER3
- CUT_BUFFER4
- CUT_BUFFER5
- CUT_BUFFER6
- CUT_BUFFER7
- DRAWABLE
- FONT
- INTEGER
- PIXMAP
- POINT
- RECTANGLE
- RESOURCE_MANAGER
- RGB_COLOR_MAP
- RGB_BEST_MAP
- RGB_BLUE_MAP
- RGB_DEFAULT_MAP
- RGB_GRAY_MAP
- RGB_GREEN_MAP
- RGB_RED_MAP
- STRING
- VISUALID
- WINDOW
- WM_COMMAND
- WM_HINTS
- WM_CLIENT_MACHINE
- WM_ICON_NAME
- WM_ICON_SIZE
- WM_NAME
- WM_NORMAL_HINTS
- WM_SIZE_HINTS
- WM_ZOOM_HINTS
- MIN_SPACE
- NORM_SPACE
- MAX_SPACE
- END_SPACE
- SUPERSCRIPT_X
- SUPERSCRIPT_Y
- SUBSCRIPT_X
- SUBSCRIPT_Y
- UNDERLINE_POSITION
- UNDERLINE_THICKNESS
- STRIKEOUT_ASCENT
- STRIKEOUT_DESCENT
- ITALIC_ANGLE
- X_HEIGHT
- QUAD_WIDTH
- WEIGHT
- POINT_SIZE
- RESOLUTION
- COPYRIGHT
- NOTICE
- FONT_NAME
- FAMILY_NAME
- FULL_NAME
- CAP_HEIGHT
- WM_CLASS
- WM_TRANSIENT_FOR))
+ primary
+ secondary
+ arc
+ atom
+ bitmap
+ cardinal
+ colormap
+ cursor
+ cut_buffer0
+ cut_buffer1
+ cut_buffer2
+ cut_buffer3
+ cut_buffer4
+ cut_buffer5
+ cut_buffer6
+ cut_buffer7
+ drawable
+ font
+ integer
+ pixmap
+ point
+ rectangle
+ resource_manager
+ rgb_color_map
+ rgb_best_map
+ rgb_blue_map
+ rgb_default_map
+ rgb_gray_map
+ rgb_green_map
+ rgb_red_map
+ string
+ visualid
+ window
+ wm_command
+ wm_hints
+ wm_client_machine
+ wm_icon_name
+ wm_icon_size
+ wm_name
+ wm_normal_hints
+ wm_size_hints
+ wm_zoom_hints
+ min_space
+ norm_space
+ max_space
+ end_space
+ superscript_x
+ superscript_y
+ subscript_x
+ subscript_y
+ underline_position
+ underline_thickness
+ strikeout_ascent
+ strikeout_descent
+ italic_angle
+ x_height
+ quad_width
+ weight
+ point_size
+ resolution
+ copyright
+ notice
+ font_name
+ family_name
+ full_name
+ cap_height
+ wm_class
+ wm_transient_for))
\f
(define (symbol->x-atom display name soft?)
(or (hash-table-ref/default built-in-atoms-table name #f)
(x-window-id xterm)
last-focus-time
string))))
- (own-selection 'PRIMARY)
+ (own-selection 'primary)
(if (ref-variable x-cut-to-clipboard context)
- (own-selection 'CLIPBOARD))))))
+ (own-selection 'clipboard))))))
(define (own-selection display selection window time value)
(and (eqv? window
(hash-table-set! table key result)
result))))))
-;;; In the next two procedures, we must allow TIME to be 0, even
+;;; In the next two procedures, we must allow time to be 0, even
;;; though the ICCCM forbids this, because existing clients use that
-;;; value. An example of a broken client is GTK+ version 1.2.6.
+;;; value. An example of a broken client is Gtk+ version 1.2.6.
(define (display/selection-record display name time)
(let ((record
data)
target))))
(case target
- ((STRING)
+ ((string)
(win 8 (selection-record/value record)))
- ((TARGETS)
- (win 32 (atoms->property-data '(STRING TIMESTAMP) display)))
- ((TIMESTAMP)
+ ((targets)
+ (win 32 (atoms->property-data '(string timestamp) display)))
+ ((timestamp)
(win 32 (timestamp->property-data (selection-record/time record))))
- ((MULTIPLE)
+ ((multiple)
(and multiple?
(let ((alist
(property-data->atom-alist
(or (get-window-property display requestor property
- 'MULTIPLE #f)
+ 'multiple #f)
(error "Missing MULTIPLE property:" property))
display)))
(for-each (lambda (entry)
(define (property-data->atom-alist data display)
(if (not (even? (vector-length data)))
- (error:bad-range-argument data 'PROPERTY-DATA->ATOM-ALIST))
+ (error:bad-range-argument data 'property-data->atom-alist))
(let loop ((atoms
(map (lambda (atom) (x-atom->symbol display atom))
(vector->list data))))
(define (xterm/interprogram-paste xterm context)
(or (and (ref-variable x-paste-from-clipboard context)
- (xterm/interprogram-paste-1 xterm 'CLIPBOARD))
- (xterm/interprogram-paste-1 xterm 'PRIMARY)))
+ (xterm/interprogram-paste-1 xterm 'clipboard))
+ (xterm/interprogram-paste-1 xterm 'primary)))
(define (xterm/interprogram-paste-1 xterm selection)
(with-thread-events-blocked
(lambda ()
- (let ((property '_EDWIN_TMP_)
+ (let ((property '_edwin_tmp_)
(time last-focus-time))
(cond ((display/selection-record (x-window-display xterm)
selection time)
=> selection-record/value)
- ((request-selection xterm selection 'STRING property time)
- (receive-selection xterm property 'STRING time))
- ((request-selection xterm selection 'C_STRING property time)
- (receive-selection xterm property 'C_STRING time))
+ ((request-selection xterm selection 'string property time)
+ (receive-selection xterm property 'string time))
+ ((request-selection xterm selection 'c_string property time)
+ (receive-selection xterm property 'c_string time))
(else #f))))))
(define (request-selection xterm selection target property time)
(x-delete-property display window property)
(x-convert-selection display selection target property window time)
(x-display-flush display)
- (eq? 'REQUEST-GRANTED
+ (eq? 'request-granted
(wait-for-event x-selection-timeout
(lambda (event)
(fix:= event-type:selection-notify (vector-ref event 0)))
(= target (selection-notify/target event))
(= time (selection-notify/time event))
(if (= property (selection-notify/property event))
- 'REQUEST-GRANTED
- 'REQUEST-DENIED))))))))
+ 'request-granted
+ 'request-denied))))))))
(define-structure (selection-notify (type vector)
(initial-offset 2)
(let ((value (get-xterm-property xterm property #f #t)))
(if (not value)
(error "Missing selection value."))
- (if (eq? 'INCR (car value))
+ (if (eq? 'incr (car value))
(receive-incremental-selection xterm property target time)
(and (eq? target (car value))
(cdr value)))))
unspecific)
(define (get-x-display)
- ;; X-OPEN-DISPLAY hangs, uninterruptibly, when the X server is
+ ;; x-open-display hangs, uninterruptibly, when the X server is
;; running the login loop of xdm. Can this be fixed?
(or x-display-data
(and (or x-display-name
- (let ((DISPLAY (get-environment-variable "DISPLAY")))
- (and (string? DISPLAY)
- (not (string-null? DISPLAY)))))
+ (let ((display (get-environment-variable "DISPLAY")))
+ (and (string? display)
+ (not (string-null? display)))))
(plugin-available? "x11")
(begin
- (load-option 'X11)
+ (load-option 'x11)
(let ((display (x-open-display x-display-name)))
(set! x-display-data display)
(set! x-display-events (make-queue))
#| -*-Scheme-*- |#
-(define-load-option 'X11
+(define-load-option 'x11
(standard-system-loader "."))
(further-load-options #t)
\ No newline at end of file
(loop scms chs cdecls (cons section rest))))))))))
(parameterize ((param:suppress-loading-message? #t))
- (load-option 'FFI))
+ (load-option 'ffi))
((access rewrite-file (->environment '(ffi build)))
(merge-pathnames "TAGS")
rewriter)))
(string-null? display)))
(warn "DISPLAY not set")
(begin
- (load-option 'X11)
+ (load-option 'x11)
(load "x11-test.scm" (->environment '(x11)))))
)
EOF
(C-call "x_graphics_reconfigure" window width height))
(define (x-graphics-open-window display geometry suppress-map)
- ;; Open a window on DISPLAY using GEOMETRY. If GEOMETRY is false
- ;; map window interactively. If third argument SUPPRESS-MAP? is
+ ;; Open a window on display using geometry. If geometry is false
+ ;; map window interactively. If third argument suppress-map? is
;; true, do not map the window immediately.
(receive (name class map?)
(cond ((and (pair? suppress-map)
(define (x-graphics-draw-arc window x y radius-x radius-y
start-angle sweep-angle fill?)
;; Draw an arc at the given coordinates, with given X and Y radii.
- ;; START-ANGLE and SWEEP-ANGLE are in degrees, anti-clocwise.
- ;; START-ANGLE is from 3 o'clock, and SWEEP-ANGLE is relative to the
- ;; START-ANGLE. If FILL? is true, the arc is filled.
+ ;; Start-angle and sweep-angle are in degrees, anti-clocwise.
+ ;; Start-angle is from 3 o'clock, and sweep-angle is relative to the
+ ;; start-angle. If fill? is true, the arc is filled.
(C-call "x_graphics_draw_arc" window
x y radius-x radius-y start-angle sweep-angle (if fill? 1 0)))
(free points))))
(define (x-create-image window width height)
- ;; Creates and returns an XImage object, of dimensions WIDTH by HEIGHT.
- ;; WINDOW is used to set the Display, Visual, and Depth characteristics.
+ ;; Creates and returns an XImage object, of dimensions width by height.
+ ;; Window is used to set the Display, Visual, and Depth characteristics.
;; The image is created by calling XCreateImage.
(let ((result (C-call "x_create_image" (make-alien '(struct |xwindow|))
window width height)))
result)))
(define (x-bytes-into-image vector image)
- ;; VECTOR is a bytevector of pixel values stored in row-major order; it must
- ;; have the same number of pixels as IMAGE. These pixels are written onto
- ;; IMAGE by repeated calls to XPutPixel. This procedure is equivalent to
- ;; calling X-SET-PIXEL-IN-IMAGE for each pixel in VECTOR.
+ ;; Vector is a bytevector of pixel values stored in row-major order; it must
+ ;; have the same number of pixels as image. These pixels are written onto
+ ;; image by repeated calls to XPutPixel. This procedure is equivalent to
+ ;; calling x-set-pixel-in-image for each pixel in vector.
(guarantee bytevector? vector 'x-bytes-into-image)
(C-call "x_bytes_into_image" vector image))
window x-window-offset y-window-offset width height))
(define (x-window-depth window)
- ;; Returns the pixel depth of WINDOW as an integer.
+ ;; Returns the pixel depth of window as an integer.
(C-call "x_window_depth" window))
(define (x-graphics-map-x-coordinate window x)
((5) (error:bad-range-argument highlight 'xterm-clear-rectangle)))))
(define (xterm-scroll-lines-up xterm x-start x-end y-start y-end lines)
- ;; Scroll the contents of the region up by LINES.
+ ;; Scroll the contents of the region up by lines.
(let ((code (c-call "xterm_scroll_lines_up"
xterm x-start x-end y-start y-end lines)))
(case code
((5) (error:bad-range-argument lines 'xterm-scroll-lines-up)))))
(define (xterm-scroll-lines-down xterm x-start x-end y-start y-end lines)
- ;; Scroll the contents of the region down by LINES.
+ ;; Scroll the contents of the region down by lines.
(let ((code (c-call "xterm_scroll_lines_down"
xterm x-start x-end y-start y-end lines)))
(case code
(define (xterm-save-contents xterm x-start x-end y-start y-end)
;; Get the contents of the terminal screen rectangle as a bytevector.
- ;; The bytevector contains alternating (CHARACTER, HIGHLIGHT) pairs.
- ;; The pairs are organized in row-major order from (X-START, Y-START).
+ ;; The bytevector contains alternating (character, highlight) pairs.
+ ;; The pairs are organized in row-major order from (x-start, y-start).
(let* ((bytevector (make-bytevector (* 2
(- x-end x-start)
(- y-end y-start))))
bytevector))
(define (xterm-restore-contents xterm x-start x-end y-start y-end contents)
- ;; Replace the terminal screen rectangle with CONTENTS.
- ;; See `XTERM-SCREEN-CONTENTS' for the format of CONTENTS.
+ ;; Replace the terminal screen rectangle with contents.
+ ;; See `xterm-screen-contents' for the format of contents.
(if (not (= (bytevector-length contents)
(* 2
(- x-end x-start)
projects / mit-scheme.git / commitdiff