From: Matt Birkholz Date: Wed, 3 Jul 2019 20:14:36 +0000 (-0700) Subject: Downcase many symbols. X-Git-Tag: mit-scheme-pucked-10.1.11~3 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=3190ddf613ba75f5168e928d35dde2c99681ad19;p=mit-scheme.git Downcase many symbols. --- diff --git a/src/blowfish/blowfish-check.scm b/src/blowfish/blowfish-check.scm index 0128b445f..cc38d808d 100644 --- a/src/blowfish/blowfish-check.scm +++ b/src/blowfish/blowfish-check.scm @@ -24,7 +24,7 @@ USA. |# -;;;; Test the BLOWFISH option. +;;;; Test the blowfish option. (let ((sample (string->utf8 "Some text to encrypt and decrypt."))) (call-with-binary-output-file "test" diff --git a/src/blowfish/blowfish-check.sh b/src/blowfish/blowfish-check.sh index edf275a27..28a78864b 100755 --- a/src/blowfish/blowfish-check.sh +++ b/src/blowfish/blowfish-check.sh @@ -1,9 +1,9 @@ #!/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 diff --git a/src/blowfish/blowfish-test.scm b/src/blowfish/blowfish-test.scm index 503a8e38c..bacd3e9e7 100644 --- a/src/blowfish/blowfish-test.scm +++ b/src/blowfish/blowfish-test.scm @@ -38,13 +38,13 @@ USA. (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))) @@ -79,13 +79,13 @@ USA. ((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))) @@ -199,7 +199,7 @@ USA. (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)) @@ -207,7 +207,7 @@ USA. (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)) diff --git a/src/blowfish/compile.scm b/src/blowfish/compile.scm index 0ff7cff1d..fbbcabbc3 100644 --- a/src/blowfish/compile.scm +++ b/src/blowfish/compile.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- |# -;;;; Compile the BLOWFISH option. +;;;; Compile the blowfish option. (for-each load-option '(cref ffi)) diff --git a/src/blowfish/make.scm b/src/blowfish/make.scm index d0f9995be..62fbb7387 100644 --- a/src/blowfish/make.scm +++ b/src/blowfish/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- |# -;;;; Load the BLOWFISH option. +;;;; Load the blowfish option. (with-working-directory-pathname (directory-pathname (current-load-pathname)) (lambda () diff --git a/src/blowfish/optiondb.scm b/src/blowfish/optiondb.scm index 25c83119f..464571513 100644 --- a/src/blowfish/optiondb.scm +++ b/src/blowfish/optiondb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- |# -(define-load-option 'BLOWFISH +(define-load-option 'blowfish (standard-system-loader ".")) (further-load-options #t) \ No newline at end of file diff --git a/src/blowfish/tags-fix.sh b/src/blowfish/tags-fix.sh index c100cbd4b..e83316cd6 100755 --- a/src/blowfish/tags-fix.sh +++ b/src/blowfish/tags-fix.sh @@ -84,7 +84,7 @@ ${MIT_SCHEME_EXE} --batch-mode -- ${1+"$@"} <<\EOF (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))) diff --git a/src/cairo/cairo-check.sh b/src/cairo/cairo-check.sh index 4c3207a85..547e7d00a 100755 --- a/src/cairo/cairo-check.sh +++ b/src/cairo/cairo-check.sh @@ -1,10 +1,10 @@ #!/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 diff --git a/src/cairo/cairo-graphics.scm b/src/cairo/cairo-graphics.scm index 802118f6e..5a6e881e8 100644 --- a/src/cairo/cairo-graphics.scm +++ b/src/cairo/cairo-graphics.scm @@ -185,22 +185,22 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -294,7 +294,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) diff --git a/src/cairo/cairo.scm b/src/cairo/cairo.scm index 9879f7fac..6ab90ebd5 100644 --- a/src/cairo/cairo.scm +++ b/src/cairo/cairo.scm @@ -257,36 +257,36 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))))) @@ -416,13 +416,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (- 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)))) diff --git a/src/cairo/compile.sh b/src/cairo/compile.sh index 8beae9d1c..7c80f684f 100755 --- a/src/cairo/compile.sh +++ b/src/cairo/compile.sh @@ -21,7 +21,7 @@ # 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} @@ -29,12 +29,10 @@ ${MIT_SCHEME_EXE} --prepend-library . --batch-mode <<\EOF (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-timestring (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))) @@ -265,7 +265,7 @@ USA. (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))) @@ -300,35 +300,35 @@ USA. (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))) @@ -338,18 +338,18 @@ USA. (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 @@ -362,20 +362,20 @@ USA. (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 diff --git a/src/ffi/ctypes.scm b/src/ffi/ctypes.scm index 27293a797..2fa2536d7 100644 --- a/src/ffi/ctypes.scm +++ b/src/ffi/ctypes.scm @@ -45,30 +45,30 @@ USA. (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)))) @@ -86,7 +86,7 @@ USA. (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)) @@ -94,25 +94,25 @@ USA. (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)))) @@ -130,7 +130,7 @@ USA. (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)) @@ -138,25 +138,25 @@ USA. (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)))) @@ -174,7 +174,7 @@ USA. (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)) @@ -182,12 +182,12 @@ USA. (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)))))) @@ -198,7 +198,7 @@ USA. (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. @@ -247,7 +247,7 @@ USA. (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) @@ -276,7 +276,7 @@ USA. (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) diff --git a/src/ffi/generator.scm b/src/ffi/generator.scm index c22e87909..dbd0ac3a9 100644 --- a/src/ffi/generator.scm +++ b/src/ffi/generator.scm @@ -79,14 +79,14 @@ USA. (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)))) @@ -282,9 +282,9 @@ Scm_"name" (void) ((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")) @@ -296,10 +296,10 @@ Scm_"name" (void) (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)))) @@ -348,14 +348,14 @@ Scm_"name" (void) (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)))) @@ -495,9 +495,9 @@ Scm_"name" ("arglist") ((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))))) @@ -590,7 +590,7 @@ grovel_enums (FILE * out) (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) @@ -607,7 +607,7 @@ grovel_enums (FILE * out) (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) @@ -633,7 +633,7 @@ grovel_enums (FILE * out) (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) @@ -645,7 +645,7 @@ void (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));")))) (_ " @@ -688,7 +688,7 @@ void (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))) diff --git a/src/ffi/syntax.scm b/src/ffi/syntax.scm index d08a90314..a0f3ed9e2 100644 --- a/src/ffi/syntax.scm +++ b/src/ffi/syntax.scm @@ -38,9 +38,9 @@ USA. 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)))) @@ -51,11 +51,11 @@ USA. (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))) @@ -143,7 +143,7 @@ USA. (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") @@ -173,7 +173,7 @@ USA. `(,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)))) @@ -187,24 +187,24 @@ USA. (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) @@ -229,9 +229,9 @@ USA. ;; (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) @@ -246,7 +246,7 @@ USA. (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)))) @@ -284,7 +284,7 @@ USA. (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 @@ -300,16 +300,16 @@ USA. ;; (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") @@ -323,20 +323,20 @@ USA. (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"))) @@ -355,24 +355,24 @@ USA. (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)) @@ -393,17 +393,17 @@ USA. ;;; 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)))) @@ -416,9 +416,9 @@ USA. (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) @@ -452,12 +452,12 @@ USA. (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") @@ -486,10 +486,10 @@ USA. (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") @@ -502,12 +502,12 @@ USA. ;;; 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:" @@ -518,16 +518,16 @@ USA. (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 @@ -537,5 +537,5 @@ USA. (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 diff --git a/src/gdbm/gdbm-check.scm b/src/gdbm/gdbm-check.scm index fa7c26381..3066a9345 100644 --- a/src/gdbm/gdbm-check.scm +++ b/src/gdbm/gdbm-check.scm @@ -28,25 +28,25 @@ USA. (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)) @@ -69,9 +69,9 @@ USA. (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) stringenvironment '(gdbm))) EOF diff --git a/src/gdbm/gdbm.scm b/src/gdbm/gdbm.scm index e915d94e7..c8c673398 100644 --- a/src/gdbm/gdbm.scm +++ b/src/gdbm/gdbm.scm @@ -24,7 +24,7 @@ USA. |# -;;;; The GDBM option. +;;;; The gdbm option. ;;; package: (gdbm) (declare (usual-integrations)) @@ -83,17 +83,17 @@ USA. (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)))) @@ -113,20 +113,20 @@ USA. (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 () @@ -140,21 +140,21 @@ USA. ;; 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) @@ -164,37 +164,37 @@ USA. (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))) @@ -206,21 +206,21 @@ USA. 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)) @@ -228,53 +228,53 @@ USA. #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")))))) @@ -289,7 +289,7 @@ USA. (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 diff --git a/src/gdbm/optiondb.scm b/src/gdbm/optiondb.scm index 32d20d3cb..fe469763e 100644 --- a/src/gdbm/optiondb.scm +++ b/src/gdbm/optiondb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- |# -(define-load-option 'GDBM +(define-load-option 'gdbm (standard-system-loader ".")) (further-load-options #t) \ No newline at end of file diff --git a/src/gdbm/tags-fix.sh b/src/gdbm/tags-fix.sh index c100cbd4b..e83316cd6 100755 --- a/src/gdbm/tags-fix.sh +++ b/src/gdbm/tags-fix.sh @@ -84,7 +84,7 @@ ${MIT_SCHEME_EXE} --batch-mode -- ${1+"$@"} <<\EOF (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))) diff --git a/src/gl/README b/src/gl/README index 650e9a2f3..a26b854be 100644 --- a/src/gl/README +++ b/src/gl/README @@ -30,7 +30,7 @@ creating a short optiondb file. 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): diff --git a/src/gl/check.scm b/src/gl/check.scm index cdd03b161..05c28c627 100644 --- a/src/gl/check.scm +++ b/src/gl/check.scm @@ -23,10 +23,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;;;; 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 diff --git a/src/gl/compile.sh b/src/gl/compile.sh index b1e5a1a4a..151d4ae28 100755 --- a/src/gl/compile.sh +++ b/src/gl/compile.sh @@ -29,12 +29,12 @@ ${MIT_SCHEME_EXE} --prepend-library . --batch-mode <<\EOF (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-timeenvironment '(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 diff --git a/src/gl/gl-glx.scm b/src/gl/gl-glx.scm index b486377ca..1210d32f7 100644 --- a/src/gl/gl-glx.scm +++ b/src/gl/gl-glx.scm @@ -28,9 +28,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)) @@ -240,7 +240,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -260,7 +260,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. "\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.) @@ -281,7 +281,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. 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))) @@ -407,5 +407,5 @@ Ctrl-Up/Down - Tilt up/down."))) (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 diff --git a/src/gl/gl-glxgears.scm b/src/gl/gl-glxgears.scm index 5df540ed9..0d31c7178 100644 --- a/src/gl/gl-glxgears.scm +++ b/src/gl/gl-glxgears.scm @@ -144,7 +144,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%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) @@ -237,9 +237,9 @@ I - Toggle frame rate reports."))) (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...")) @@ -249,7 +249,7 @@ I - Toggle frame rate reports."))) (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!")) @@ -335,7 +335,7 @@ I - Toggle frame rate reports."))) (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.) @@ -372,11 +372,11 @@ I - Toggle frame rate reports."))) (%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) @@ -392,35 +392,35 @@ I - Toggle frame rate reports."))) (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 @@ -439,11 +439,11 @@ I - Toggle frame rate reports."))) (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))) @@ -456,7 +456,7 @@ I - Toggle frame rate reports."))) (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))) @@ -473,7 +473,7 @@ I - Toggle frame rate reports."))) (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))) @@ -487,7 +487,7 @@ I - Toggle frame rate reports."))) (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))) @@ -502,7 +502,7 @@ I - Toggle frame rate reports."))) (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))) @@ -530,10 +530,10 @@ I - Toggle frame rate reports."))) (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))) @@ -568,12 +568,12 @@ I - Toggle frame rate reports."))) (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 diff --git a/src/gl/gl.scm b/src/gl/gl.scm index 3ab195e63..5ee8151d8 100644 --- a/src/gl/gl.scm +++ b/src/gl/gl.scm @@ -27,351 +27,351 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)) (define param:gl-context-current?) diff --git a/src/gl/glxgears-compile.scm b/src/gl/glxgears-compile.scm index 4b362c9d3..1943ecc9f 100644 --- a/src/gl/glxgears-compile.scm +++ b/src/gl/glxgears-compile.scm @@ -23,14 +23,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;;;; 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")) @@ -41,4 +41,4 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 diff --git a/src/gl/glxgears.scm b/src/gl/glxgears.scm index f300152d8..e7ca6b494 100644 --- a/src/gl/glxgears.scm +++ b/src/gl/glxgears.scm @@ -59,11 +59,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -76,7 +76,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -93,7 +93,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -107,7 +107,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -122,7 +122,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -150,10 +150,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -170,7 +170,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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.) @@ -200,13 +200,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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.) @@ -214,13 +214,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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.) @@ -284,11 +284,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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.))) @@ -299,35 +299,35 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)) @@ -557,32 +557,32 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -590,15 +590,15 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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") @@ -611,11 +611,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)))))) @@ -703,10 +703,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -752,7 +752,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 diff --git a/src/gl/make.scm b/src/gl/make.scm index ae4cc7932..9873a7ec2 100644 --- a/src/gl/make.scm +++ b/src/gl/make.scm @@ -2,7 +2,7 @@ ;;;; Load the GL option. -(load-option 'GTK) +(load-option 'gtk) (with-loader-base-uri (system-library-uri "gl/") (lambda () (load-package-set "gl"))) diff --git a/src/gl/optiondb.scm b/src/gl/optiondb.scm index f41a00dc4..ad20870ef 100644 --- a/src/gl/optiondb.scm +++ b/src/gl/optiondb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- |# -(define-load-option 'GL +(define-load-option 'gl (let ((pathname (merge-pathnames "make" (directory-pathname (current-load-pathname))))) diff --git a/src/gl/tags-fix.sh b/src/gl/tags-fix.sh index aee615c48..2a8ec6437 100755 --- a/src/gl/tags-fix.sh +++ b/src/gl/tags-fix.sh @@ -35,7 +35,7 @@ ${MIT_SCHEME_EXE} --batch-mode -- "${@}" <<\EOF (loop skipping?)))))) (parameterize ((param:suppress-loading-message? #t)) - (load-option 'FFI)) + (load-option 'ffi)) ((access rewrite-file (->environment '(ffi build))) (merge-pathnames "TAGS") rewriter))) diff --git a/src/glib/compile.sh b/src/glib/compile.sh index 9fe508ec8..c9240e89f 100755 --- a/src/glib/compile.sh +++ b/src/glib/compile.sh @@ -29,12 +29,10 @@ ${MIT_SCHEME_EXE} --prepend-library . --batch-mode <<\EOF (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-timeuri* object caller) @@ -94,8 +94,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. '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) @@ -160,10 +160,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;;; which, if not null, references a GError that must be freed. (define-structure gio-cleanup-info - pending-op ; #f, , CLOSED or ERROR. The first one + pending-op ; #f, , closed or error. The first one ; means "idle" and the last two are more ; permanent states than "op"s. 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 @@ -180,21 +180,21 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -209,7 +209,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -219,7 +219,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)))) @@ -274,7 +274,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -287,7 +287,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -343,7 +343,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -355,7 +355,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -399,7 +399,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -411,11 +411,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))))))) @@ -471,7 +471,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -485,7 +485,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -511,7 +511,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -522,7 +522,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -577,7 +577,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -617,7 +617,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))))))) @@ -653,7 +653,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -667,17 +667,17 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -699,7 +699,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -713,14 +713,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -736,14 +736,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ((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)))) (define-class ( (constructor ())) ()) @@ -759,7 +759,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -774,7 +774,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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*) @@ -892,7 +892,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -931,7 +931,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -943,7 +943,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -1045,7 +1045,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))))) @@ -1074,7 +1074,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -1096,22 +1096,22 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -1124,7 +1124,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -1201,15 +1201,15 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -1312,12 +1312,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 diff --git a/src/glib/glib-check-copy.sh b/src/glib/glib-check-copy.sh index db88a46bc..5ad8669e0 100755 --- a/src/glib/glib-check-copy.sh +++ b/src/glib/glib-check-copy.sh @@ -21,7 +21,7 @@ # 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. @@ -29,7 +29,7 @@ set -e : ${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")) diff --git a/src/glib/glib-check-list.sh b/src/glib/glib-check-list.sh index eb4b37abf..25b560232 100755 --- a/src/glib/glib-check-list.sh +++ b/src/glib/glib-check-list.sh @@ -21,7 +21,7 @@ # 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. @@ -30,7 +30,7 @@ set -e : ${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 n m) n m)) @@ -63,7 +63,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -130,7 +130,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)) diff --git a/src/glib/gobject.scm b/src/glib/gobject.scm index f555cc42d..f2704779d 100644 --- a/src/glib/gobject.scm +++ b/src/glib/gobject.scm @@ -80,7 +80,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -336,7 +336,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 diff --git a/src/gtk-screen/README b/src/gtk-screen/README index 53cedb25f..bd293325a 100644 --- a/src/gtk-screen/README +++ b/src/gtk-screen/README @@ -1,4 +1,4 @@ -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 @@ -27,10 +27,10 @@ creating a short optiondb file. 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) diff --git a/src/gtk-screen/check.sh b/src/gtk-screen/check.sh index 78506e5d0..b15ad70e4 100755 --- a/src/gtk-screen/check.sh +++ b/src/gtk-screen/check.sh @@ -21,13 +21,13 @@ # 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)))) @@ -49,6 +49,6 @@ ${MIT_SCHEME_EXE} --prepend-library . --batch-mode <<\EOF (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 diff --git a/src/gtk-screen/compile.sh b/src/gtk-screen/compile.sh index c579a71d4..d8dd5aca0 100755 --- a/src/gtk-screen/compile.sh +++ b/src/gtk-screen/compile.sh @@ -21,7 +21,7 @@ # 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} @@ -33,8 +33,8 @@ ${MIT_SCHEME_EXE} --batch-mode <<\EOF (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 for Edwin. +;;;; A Gtk-based for Edwin. ;;; Package: (edwin screen gtk-screen) (define-class ( @@ -90,7 +90,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)) @@ -209,7 +209,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-syntax %trace3 (syntax-rules () - ((_ ARGS ...) (if %trace-blinker? (outf-error ARGS ...))))) + ((_ args ...) (if %trace-blinker? (outf-error args ...))))) (create-thread #f @@ -284,7 +284,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace "; screen/window-scroll-y-absolute! "screen" "frame" "y-point"\n") (assert-glib-locked '(screen/window-scroll-y-absolute! )) (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))) @@ -329,7 +329,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace "; screen/window-scroll-y-relative! "screen" "frame" "delta"\n") (assert-glib-locked '(screen/window-scroll-y-relative! )) (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))) @@ -343,7 +343,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace "; screen/set-window-start-mark! "screen" "frame" "mark" "force?"\n") (assert-glib-locked '(screen/set-window-start-mark! )) (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))) @@ -368,7 +368,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace "; screen/window-mark-visible? "screen" "frame" "mark"\n") (assert-glib-locked '(screen/window-mark-visible? )) (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))) @@ -390,7 +390,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace "; screen/window-mark->x "screen" "frame" "mark"\n") (assert-glib-locked '(screen/window-mark->x )) (with-updated-window - screen frame 'MARK->X + screen frame 'mark->x (lambda (widget) (let ((line (find-line-at mark widget))) (if (not line) @@ -407,7 +407,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace "; screen/window-mark->y "screen" "frame" "mark"\n") (assert-glib-locked '(screen/window-mark->y )) (with-updated-window - screen frame 'MARK->Y + screen frame 'mark->y (lambda (widget) (let ((line (find-line-at mark widget))) (if (not line) @@ -428,7 +428,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace "; screen/window-mark->coordinates "screen" "frame" "mark"\n") (assert-glib-locked '(screen/window-mark->coordinates )) (with-updated-window - screen frame 'MARK->COORDINATES + screen frame 'mark->coordinates (lambda (widget) (let ((line (find-line-at mark widget))) (if (not line) @@ -454,7 +454,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%trace-buttons "coordinates->mark "screen" "frame" "x" "y) (assert-glib-locked '(screen/window-coordinates->mark! )) (with-updated-window - screen frame 'COORDINATES->MARK + screen frame 'coordinates->mark (lambda (widget) (let ((drawing (fix-layout-drawing widget)) (view (fix-layout-view widget)) @@ -491,7 +491,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -510,7 +510,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)) @@ -540,7 +540,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -627,18 +627,18 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 () @@ -650,19 +650,19 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%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)) @@ -675,27 +675,27 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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."))))))) @@ -779,9 +779,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%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) @@ -811,7 +811,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -832,7 +832,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%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) @@ -871,10 +871,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -885,7 +885,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define (initialize-package!) (set! screen-list '()) (set! gtk-display-type - (make-display-type 'GTK + (make-display-type 'gtk #t gtk-initialized? make-gtk-screen @@ -995,7 +995,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -1009,11 +1009,11 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (%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) @@ -1022,7 +1022,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))))) @@ -1175,7 +1175,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)) @@ -1253,7 +1253,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 )) @@ -1278,7 +1278,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -1300,7 +1300,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)) @@ -1469,7 +1469,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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") @@ -1573,10 +1573,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ((display-style/no-screen-output? display-style) (invalidate-all-drawings! screen) (%trace "; (update-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! ) done: "visibility"\n") @@ -1670,7 +1670,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -1721,7 +1721,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)) @@ -1836,7 +1836,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. window format (ref-variable frame-name-length buffer)))))) (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 @@ -1907,8 +1907,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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:" @@ -2294,15 +2294,15 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. 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") @@ -2372,17 +2372,17 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;; 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))) @@ -2467,7 +2467,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -2655,7 +2655,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 () @@ -2708,19 +2708,19 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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"))) diff --git a/src/gtk-screen/make.scm b/src/gtk-screen/make.scm index a695e9645..0f18ceeb1 100644 --- a/src/gtk-screen/make.scm +++ b/src/gtk-screen/make.scm @@ -2,8 +2,8 @@ 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"))) diff --git a/src/gtk-screen/optiondb.scm b/src/gtk-screen/optiondb.scm index 6c3ff44f7..478b3c7f5 100644 --- a/src/gtk-screen/optiondb.scm +++ b/src/gtk-screen/optiondb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- |# -(define-load-option 'GTK-SCREEN +(define-load-option 'gtk-screen (let ((pathname (merge-pathnames "make" (directory-pathname (current-load-pathname))))) diff --git a/src/gtk/compile.sh b/src/gtk/compile.sh index 6d78847c2..8bf63f95d 100755 --- a/src/gtk/compile.sh +++ b/src/gtk/compile.sh @@ -29,9 +29,7 @@ ${MIT_SCHEME_EXE} --prepend-library . --batch-mode <<\EOF (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.")) diff --git a/src/gtk/gtk-check.sh b/src/gtk/gtk-check.sh index 56e313bee..e10004599 100755 --- a/src/gtk/gtk-check.sh +++ b/src/gtk/gtk-check.sh @@ -27,8 +27,8 @@ set -e : ${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?) diff --git a/src/gtk/gtk.texi b/src/gtk/gtk.texi index e35ad6526..4499563ef 100644 --- a/src/gtk/gtk.texi +++ b/src/gtk/gtk.texi @@ -104,7 +104,7 @@ Here is the ``Hello, World!'' program from the C/Unix FFI @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 @@ -112,7 +112,7 @@ To run this program, enter the following lines. @example mit-scheme - (load-option 'Gtk) + (load-option 'gtk) (ge '(gtk)) (load "hello") (hello) @@ -128,7 +128,7 @@ widget enter the following lines. @example mit-scheme - (load-option 'Gtk) + (load-option 'gtk) (make-gtk-event-viewer-demo) @end example @@ -154,7 +154,7 @@ enter the following lines. @example mit-scheme - (load-option 'Gtk) + (load-option 'gtk) (make-fix-layout-demo) @end example @@ -176,7 +176,7 @@ To see the Pole Zero application, enter the following lines. @example mit-scheme-pucked - (load-option 'Gtk) + (load-option 'gtk) (make-pole-zero) @end example diff --git a/src/gtk/make.scm b/src/gtk/make.scm index 2460ca068..934b8209d 100644 --- a/src/gtk/make.scm +++ b/src/gtk/make.scm @@ -2,8 +2,8 @@ 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"))) diff --git a/src/gtk/optiondb.scm b/src/gtk/optiondb.scm index c142bbb11..a2e161f49 100644 --- a/src/gtk/optiondb.scm +++ b/src/gtk/optiondb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- |# -(define-load-option 'GTK +(define-load-option 'gtk (let ((pathname (merge-pathnames "make" (directory-pathname (current-load-pathname))))) diff --git a/src/gtk/tags-fix.sh b/src/gtk/tags-fix.sh index aee615c48..2a8ec6437 100755 --- a/src/gtk/tags-fix.sh +++ b/src/gtk/tags-fix.sh @@ -35,7 +35,7 @@ ${MIT_SCHEME_EXE} --batch-mode -- "${@}" <<\EOF (loop skipping?)))))) (parameterize ((param:suppress-loading-message? #t)) - (load-option 'FFI)) + (load-option 'ffi)) ((access rewrite-file (->environment '(ffi build))) (merge-pathnames "TAGS") rewriter))) diff --git a/src/gtk/test-gport-performance.scm b/src/gtk/test-gport-performance.scm index 9913d50f3..74d9bdaee 100644 --- a/src/gtk/test-gport-performance.scm +++ b/src/gtk/test-gport-performance.scm @@ -23,7 +23,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;;;; Test gfile port performance. -(load-option 'Gtk) +(load-option 'gtk) ;; The number of trials for each test. (define repeats 7) diff --git a/src/mcrypt/compile.scm b/src/mcrypt/compile.scm index e0a3fc740..c4f88e458 100644 --- a/src/mcrypt/compile.scm +++ b/src/mcrypt/compile.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- |# -;;;; Compile the MCRYPT option. +;;;; Compile the Mcrypt option. (for-each load-option '(cref ffi)) diff --git a/src/mcrypt/mcrypt-check.scm b/src/mcrypt/mcrypt-check.scm index 468daa764..4066abcb1 100644 --- a/src/mcrypt/mcrypt-check.scm +++ b/src/mcrypt/mcrypt-check.scm @@ -24,7 +24,7 @@ USA. |# -;;;; Test the MCRYPT option. +;;;; Test the Mcrypt option. (define (random-string length) (list->string (make-initialized-list length diff --git a/src/mcrypt/optiondb.scm b/src/mcrypt/optiondb.scm index 049c332fe..f5966dc6e 100644 --- a/src/mcrypt/optiondb.scm +++ b/src/mcrypt/optiondb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- |# -(define-load-option 'MCRYPT +(define-load-option 'mcrypt (standard-system-loader ".")) (further-load-options #t) \ No newline at end of file diff --git a/src/mcrypt/tags-fix.sh b/src/mcrypt/tags-fix.sh index c100cbd4b..e83316cd6 100755 --- a/src/mcrypt/tags-fix.sh +++ b/src/mcrypt/tags-fix.sh @@ -84,7 +84,7 @@ ${MIT_SCHEME_EXE} --batch-mode -- ${1+"$@"} <<\EOF (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))) diff --git a/src/pango/compile.sh b/src/pango/compile.sh index 96f3619da..c102163ff 100755 --- a/src/pango/compile.sh +++ b/src/pango/compile.sh @@ -29,11 +29,9 @@ ${MIT_SCHEME_EXE} --prepend-library . --batch-mode <<\EOF (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-timecolor 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 @@ -116,7 +116,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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" @@ -291,7 +291,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) diff --git a/src/pango/tags-fix.sh b/src/pango/tags-fix.sh index aee615c48..2a8ec6437 100755 --- a/src/pango/tags-fix.sh +++ b/src/pango/tags-fix.sh @@ -35,7 +35,7 @@ ${MIT_SCHEME_EXE} --batch-mode -- "${@}" <<\EOF (loop skipping?)))))) (parameterize ((param:suppress-loading-message? #t)) - (load-option 'FFI)) + (load-option 'ffi)) ((access rewrite-file (->environment '(ffi build))) (merge-pathnames "TAGS") rewriter))) diff --git a/src/pgsql/optiondb.scm b/src/pgsql/optiondb.scm index e5a0ef5dd..fab38d525 100644 --- a/src/pgsql/optiondb.scm +++ b/src/pgsql/optiondb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- |# -(define-load-option 'PGSQL +(define-load-option 'pgsql (standard-system-loader ".")) (further-load-options #t) \ No newline at end of file diff --git a/src/pgsql/pgsql-check.sh b/src/pgsql/pgsql-check.sh index 8a67307d1..94721acc5 100755 --- a/src/pgsql/pgsql-check.sh +++ b/src/pgsql/pgsql-check.sh @@ -4,6 +4,6 @@ set -e ${MIT_SCHEME_EXE} --prepend-library . <<\EOF -(load-option 'PGSQL) +(load-option 'pgsql) (load "pgsql-check" (->environment '(postgresql))) EOF diff --git a/src/pgsql/pgsql.scm b/src/pgsql/pgsql.scm index c5761a262..ca2de2bd1 100644 --- a/src/pgsql/pgsql.scm +++ b/src/pgsql/pgsql.scm @@ -283,46 +283,46 @@ USA. (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) (define pgsql-initialized? #f) (define connections) @@ -340,20 +340,20 @@ USA. (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") @@ -380,35 +380,35 @@ USA. (set! pgsql-initialized? #t)))) (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) @@ -444,7 +444,7 @@ USA. (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)))) @@ -466,11 +466,11 @@ USA. 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)) @@ -486,8 +486,8 @@ USA. 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) @@ -531,7 +531,7 @@ USA. (pq-unescape-bytea string)) (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 @@ -543,10 +543,10 @@ USA. (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)) @@ -570,9 +570,9 @@ USA. 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) diff --git a/src/pgsql/tags-fix.sh b/src/pgsql/tags-fix.sh index c100cbd4b..e83316cd6 100755 --- a/src/pgsql/tags-fix.sh +++ b/src/pgsql/tags-fix.sh @@ -84,7 +84,7 @@ ${MIT_SCHEME_EXE} --batch-mode -- ${1+"$@"} <<\EOF (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))) diff --git a/src/planetarium/README b/src/planetarium/README index 2a7d1fe8c..788aa377c 100644 --- a/src/planetarium/README +++ b/src/planetarium/README @@ -29,7 +29,7 @@ creating a short optiondb file. To use: - (load-option 'PLANETARIUM) + (load-option 'planetarium) (make-tellurion) A tellurion should pop up in a new window on your desktop. diff --git a/src/planetarium/mit-check.sh b/src/planetarium/mit-check.sh index e35bf8a7c..2a8721330 100755 --- a/src/planetarium/mit-check.sh +++ b/src/planetarium/mit-check.sh @@ -21,7 +21,7 @@ # 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} @@ -29,7 +29,7 @@ ${MIT_SCHEME_EXE} --prepend-library . <<\EOF (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.") diff --git a/src/planetarium/mit-compile.sh b/src/planetarium/mit-compile.sh index 26bcb38eb..8f1034009 100755 --- a/src/planetarium/mit-compile.sh +++ b/src/planetarium/mit-compile.sh @@ -38,11 +38,11 @@ ${MIT_SCHEME_EXE} --batch-mode <<\EOF (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-timeenvironment '(planetarium))) (graphics (cond ((graphics-type-available? 'gtk) (->environment '(planetarium gtk-graphics))) diff --git a/src/planetarium/mit-make.scm b/src/planetarium/mit-make.scm index 79b8dfa30..3d7dd6f05 100644 --- a/src/planetarium/mit-make.scm +++ b/src/planetarium/mit-make.scm @@ -21,7 +21,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. |# -;;;; 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 @@ -32,7 +32,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 diff --git a/src/planetarium/mit-optiondb.scm b/src/planetarium/mit-optiondb.scm index efba67889..f3d62b150 100644 --- a/src/planetarium/mit-optiondb.scm +++ b/src/planetarium/mit-optiondb.scm @@ -2,7 +2,7 @@ ;;;; 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))))) diff --git a/src/planetarium/mit-r3rs.scm b/src/planetarium/mit-r3rs.scm index 3284fd144..a28067109 100644 --- a/src/planetarium/mit-r3rs.scm +++ b/src/planetarium/mit-r3rs.scm @@ -26,13 +26,13 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)) @@ -62,10 +62,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)) @@ -94,5 +94,5 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 diff --git a/src/planetarium/mit-snapshot.scm b/src/planetarium/mit-snapshot.scm index f869ed38f..79396e274 100644 --- a/src/planetarium/mit-snapshot.scm +++ b/src/planetarium/mit-snapshot.scm @@ -24,7 +24,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;;;; 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)) diff --git a/src/planetarium/mit-syntax.scm b/src/planetarium/mit-syntax.scm index 1d5fa5382..39f290ae7 100644 --- a/src/planetarium/mit-syntax.scm +++ b/src/planetarium/mit-syntax.scm @@ -26,10 +26,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 @@ -44,7 +44,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) diff --git a/src/planetarium/solar.scm b/src/planetarium/solar.scm index 6cb988ab9..7e4a6dd6e 100644 --- a/src/planetarium/solar.scm +++ b/src/planetarium/solar.scm @@ -111,7 +111,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) diff --git a/src/planetarium/tellurion.scm b/src/planetarium/tellurion.scm index a6c74daa6..4b9f46a16 100644 --- a/src/planetarium/tellurion.scm +++ b/src/planetarium/tellurion.scm @@ -30,7 +30,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. 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)) @@ -38,17 +38,17 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)))) @@ -65,7 +65,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ((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)) @@ -96,16 +96,16 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))))) diff --git a/src/planetarium/terrain.scm b/src/planetarium/terrain.scm index 95ee3afe8..5c1269ee8 100644 --- a/src/planetarium/terrain.scm +++ b/src/planetarium/terrain.scm @@ -31,14 +31,14 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)))) @@ -53,21 +53,21 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -139,10 +139,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (width height))) () - ;; 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) @@ -163,7 +163,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ;; 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.))) @@ -194,24 +194,24 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)))) @@ -219,7 +219,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (define-method glx-viewport-draw ((widget )) (%trace2 "; (glx-viewport-draw )\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)) @@ -260,30 +260,30 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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") @@ -319,7 +319,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -517,12 +517,12 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 diff --git a/src/x11-screen/README b/src/x11-screen/README index 02ad443fb..a81517853 100644 --- a/src/x11-screen/README +++ b/src/x11-screen/README @@ -1,4 +1,4 @@ -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 diff --git a/src/x11-screen/optiondb.scm b/src/x11-screen/optiondb.scm index 8625f75fc..d1186c1e1 100644 --- a/src/x11-screen/optiondb.scm +++ b/src/x11-screen/optiondb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- |# -(define-load-option 'X11-SCREEN +(define-load-option 'x11-screen (standard-system-loader ".")) (further-load-options #t) \ No newline at end of file diff --git a/src/x11-screen/x11-command.scm b/src/x11-screen/x11-command.scm index 31394b2df..d690b9bfe 100644 --- a/src/x11-screen/x11-command.scm +++ b/src/x11-screen/x11-command.scm @@ -268,8 +268,8 @@ When called interactively, completion is available on the input." (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) diff --git a/src/x11-screen/x11-screen-check.sh b/src/x11-screen/x11-screen-check.sh index 1fcd946f4..58aed1522 100755 --- a/src/x11-screen/x11-screen-check.sh +++ b/src/x11-screen/x11-screen-check.sh @@ -1,7 +1,7 @@ #!/bin/sh # -*-Scheme-*- # -# Test the X11-SCREEN option. +# Test the X11 Screen option. set -e ${MIT_SCHEME_EXE} --prepend-library . <<\EOF diff --git a/src/x11-screen/x11-screen-test.scm b/src/x11-screen/x11-screen-test.scm index 3ba507c76..5f53948d6 100644 --- a/src/x11-screen/x11-screen-test.scm +++ b/src/x11-screen/x11-screen-test.scm @@ -33,8 +33,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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 diff --git a/src/x11-screen/x11-screen.scm b/src/x11-screen/x11-screen.scm index e69f37856..ebe093196 100644 --- a/src/x11-screen/x11-screen.scm +++ b/src/x11-screen/x11-screen.scm @@ -53,7 +53,7 @@ USA. (selected? #t) (name #f) (icon-name #f) - (x-visibility 'VISIBLE) + (x-visibility 'visible) (mapped? #f) (unexposed? #t)) @@ -130,10 +130,10 @@ USA. ;;; 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))) @@ -166,7 +166,7 @@ USA. (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) @@ -175,7 +175,7 @@ USA. (if (and (screen-mapped? screen) (screen-exposed? screen)) (screen-x-visibility screen) - 'UNMAPPED)))) + 'unmapped)))) (define (screen-xterm screen) (xterm-screen-state/xterm (screen-state screen))) @@ -258,7 +258,7 @@ USA. (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))) @@ -284,11 +284,11 @@ USA. (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)) @@ -368,7 +368,7 @@ USA. (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 @@ -537,7 +537,7 @@ USA. (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) @@ -655,42 +655,42 @@ USA. (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))))))) (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)) @@ -711,9 +711,9 @@ USA. (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))) @@ -723,7 +723,7 @@ USA. (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 @@ -733,7 +733,7 @@ USA. (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 @@ -749,91 +749,91 @@ USA. (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))) ;;;; 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)) (define (symbol->x-atom display name soft?) (or (hash-table-ref/default built-in-atoms-table name #f) @@ -1034,9 +1034,9 @@ In either case, it is copied to the primary selection." (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 @@ -1059,9 +1059,9 @@ In either case, it is copied to the primary selection." (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 @@ -1145,18 +1145,18 @@ In either case, it is copied to the primary selection." 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) @@ -1180,7 +1180,7 @@ In either case, it is copied to the primary selection." (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)))) @@ -1212,21 +1212,21 @@ Otherwise, it is copied from the primary selection." (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) @@ -1238,7 +1238,7 @@ Otherwise, it is copied from the primary selection." (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))) @@ -1248,8 +1248,8 @@ Otherwise, it is copied from the primary selection." (= 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) @@ -1264,7 +1264,7 @@ Otherwise, it is copied from the primary selection." (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))))) @@ -1366,16 +1366,16 @@ Otherwise, it is copied from the primary selection." 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)) diff --git a/src/x11/optiondb.scm b/src/x11/optiondb.scm index 9aae8c805..87dc02702 100644 --- a/src/x11/optiondb.scm +++ b/src/x11/optiondb.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- |# -(define-load-option 'X11 +(define-load-option 'x11 (standard-system-loader ".")) (further-load-options #t) \ No newline at end of file diff --git a/src/x11/tags-fix.sh b/src/x11/tags-fix.sh index c100cbd4b..e83316cd6 100755 --- a/src/x11/tags-fix.sh +++ b/src/x11/tags-fix.sh @@ -84,7 +84,7 @@ ${MIT_SCHEME_EXE} --batch-mode -- ${1+"$@"} <<\EOF (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))) diff --git a/src/x11/x11-check.sh b/src/x11/x11-check.sh index 0ad83f3ce..3c565a421 100755 --- a/src/x11/x11-check.sh +++ b/src/x11/x11-check.sh @@ -11,7 +11,7 @@ ${MIT_SCHEME_EXE} --prepend-library . <<\EOF (string-null? display))) (warn "DISPLAY not set") (begin - (load-option 'X11) + (load-option 'x11) (load "x11-test.scm" (->environment '(x11))))) ) EOF diff --git a/src/x11/x11-graphics.scm b/src/x11/x11-graphics.scm index 9ca2a0f1a..d1d96aa2b 100644 --- a/src/x11/x11-graphics.scm +++ b/src/x11/x11-graphics.scm @@ -62,8 +62,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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) @@ -115,9 +115,9 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -182,8 +182,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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))) @@ -192,10 +192,10 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. 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)) @@ -224,7 +224,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. 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) diff --git a/src/x11/x11-terminal.scm b/src/x11/x11-terminal.scm index 4e1c43b51..cd082b948 100644 --- a/src/x11/x11-terminal.scm +++ b/src/x11/x11-terminal.scm @@ -135,7 +135,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ((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 @@ -146,7 +146,7 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. ((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 @@ -158,8 +158,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. (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)))) @@ -173,8 +173,8 @@ Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. 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)