Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Set up test cases, types, enums, and structs are working

  • Loading branch information...
commit 02e19378937be5ee96f40953ba19930df7c3a8d2 1 parent da584ce
@mwitmer authored
View
102 language/xml-xcb/compile-scheme.scm
@@ -2,6 +2,8 @@
#:use-module (ice-9 regex)
#:use-module (ice-9 receive)
#:use-module (srfi srfi-1)
+ #:use-module (xcb xml struct)
+ #:use-module (xcb xml type)
#:use-module (sxml simple)
#:use-module (sxml match))
@@ -98,7 +100,11 @@
(receive (matches rest)
(partition
(lambda (element)
- (eq? (element-syntax-tag element) (caar inner-groups)))
+ (let ((syntax-tag-names (caar inner-groups)))
+ (if (list? syntax-tag-names)
+ (find (lambda (el) (eq? el (element-syntax-tag element)))
+ syntax-tag-names)
+ (eq? (element-syntax-tag element) syntax-tag-names))))
inner-elements)
(if (and (cadar inner-groups)
(< (length matches) (cadar inner-groups)))
@@ -189,7 +195,13 @@
((false-or string?) enum)
((false-or string?) altenum)
((false-or string?) mask))
- (make-element-syntax 'field #f #f))
+ (make-element-syntax 'field `(,(string->symbol name)
+ (resolve-type ,(string->symbol type)
+ ,(if mask (string->symbol mask) #f)
+ ,(cond (enum (string->symbol enum))
+ (altenum (string->symbol altenum))
+ (else #f))
+ ,(if enum #t #f))) #f))
(,otherwise (xml-xcb-parse-error exp ignore-error?))))
(define* (pad-match exp #:optional ignore-error?)
@@ -197,7 +209,7 @@
((pad (@ (bytes ,bytes)))
(guard
(xml-integer? bytes))
- (make-element-syntax 'pad #f #f))
+ (make-element-syntax 'pad `(*pad* ,(string->number bytes)) #f))
(,otherwise (xml-xcb-parse-error exp ignore-error?))))
(define* (list-match exp #:optional ignore-error?)
@@ -214,7 +226,17 @@
((false-or string?) enum)
((false-or string?) altenum)
((false-or string?) mask))
- (make-element-syntax 'list #f #f))
+ (make-element-syntax 'list `(,(string->symbol name)
+ (resolve-type ,(string->symbol type)
+ ,(if mask (string->symbol mask) #f)
+ ,(cond (enum (string->symbol enum))
+ (altenum (string->symbol altenum))
+ (else #f))
+ ,(if enum #t #f))
+ *list*
+ ,(if (= (length expression) 1)
+ (element-syntax-syntax (car expression))
+ #f)) #f))
(,otherwise (xml-xcb-parse-error exp ignore-error?))))
(define* (fields-match exp #:optional ignore-errors?)
@@ -380,7 +402,7 @@
'xidtype `(define-public
,(string->symbol name)
(self-type (quote ,(string->symbol name))
- (pack-uint-proc 4) (unpack-uint-proc 4) #t)) #f))
+ (pack-int-proc 4) (unpack-int-proc 4) #t)) #f))
((xidunion (@ (name ,name))
(type ,types) ...)
(guard
@@ -394,7 +416,7 @@
(self-union-type
(quote ,(string->symbol name))
(list ,@(map (lambda (type) (string->symbol type)) types))
- (pack-uint-proc 4) (unpack-uint-proc 4) #t)) #f))
+ (pack-int-proc 4) (unpack-int-proc 4) #t)) #f))
((enum (@ (name ,name))
,[(combine-matchers
item-match
@@ -410,15 +432,15 @@
`(begin
(define-public
,(string->symbol name)
- (make-hash-table))
+ (make-xcb-enum))
,@(let item-creator ((items items) (next-value 0))
(if (not (null? items))
(let* ((item-syntax (element-syntax-syntax (car items)))
(provided-value (cdr item-syntax)))
(cons
- `(hashq-set! ,(string->symbol name)
- (quote ,(car item-syntax))
- ,(if provided-value `(,provided-value #f) next-value))
+ `(xcb-enum-set! ,(string->symbol name)
+ (quote ,(car item-syntax))
+ ,(if provided-value `(,provided-value #f) next-value))
(if provided-value
(item-creator (cdr items) next-value)
(item-creator (cdr items) (1+ next-value)))))
@@ -445,15 +467,44 @@
switch-match) -> fields] ...)
(guard
(string? name))
- (receive (fields pads lists switches)
+ (receive (fields switches)
(partition-elements fields
- '(field 0 #f)
- '(list 0 #f)
- '(pad 0 #f)
+ '((field list pad) 0 #f)
'(switch 0 1))
- (if (= (length (append fields lists pads)) 0)
+ (if (= (length fields) 0)
(error "xml-xcb: struct must contain at least one fields element"))
- (make-element-syntax 'struct #f #f)))
+ (let ((name-sym (string->symbol name)))
+ (make-element-syntax
+ 'struct
+ `(define-xcb-struct
+ ,name-sym
+ (,(symbol-append 'make- name-sym)
+ ,@(delete
+ '*pad*
+ (map
+ (lambda (field)
+ (car (element-syntax-syntax field)))
+ (filter
+ (lambda (field)
+ (not (eq? (element-syntax-tag field) 'list)))
+ fields))))
+ ,(symbol-append name-sym '?)
+ ,(symbol-append name-sym '-type)
+ ,(if (not (null? switches))
+ (element-syntax-syntax (car switches))
+ #f)
+ ,@(map
+ (lambda (field)
+ (let* ((syn (element-syntax-syntax field))
+ (field-name (car syn)))
+ (if (eq? field-name '*pad*)
+ syn
+ (append
+ syn
+ (list
+ (symbol-append name-sym '-get- field-name)
+ (symbol-append name-sym '-set- field-name '!))))))
+ fields)) #f))))
((union (@ (name ,name))
,[(combine-matchers
switch-match
@@ -490,9 +541,13 @@
`(lambda (field-ref) (,(proc-for-op op) (,expression field-ref)))
#f))
((fieldref ,fieldref) (guard (string? fieldref))
- (make-element-syntax 'expression `(lambda (field-ref) (field-ref ,fieldref)) #f))
+ (make-element-syntax 'expression `(lambda (field-ref) (field-ref
+ ',(string->symbol fieldref))) #f))
+;;,(string->symbol fieldref)
((enumref (@ (ref ,ref)) ,enumref) (guard (string? enumref) (string? ref))
- (make-element-syntax 'expression `(lambda (field-ref) (enum-ref ,ref ,enumref)) #f))
+ (make-element-syntax 'expression `(lambda (field-ref) (enum-ref
+ ,(string->symbol ref)
+ ,(string->symbol enumref))) #f))
((sumof (@ (ref ,ref))) (guard (string? ref))
(make-element-syntax
'expression
@@ -622,15 +677,12 @@
'(typedef 0 #f)
'(import 0 #f))
`(begin
- (define-module (xcb xml ext ,(string->symbol header))
- #:use-module (xcb xml type)
- #:use-module (xcb xml struct)
- #:use-module (xcb xml common)
- ,@(if (not (string= header "xproto")) '(#:use-module (xcb xml xproto)) '())
- ,@(map (lambda (import) `(#:use-module ,(element-syntax-syntax import))) imports))
+ (use-modules
+ ,@(if (not (string= header "xproto")) '((xcb xml xproto)) '())
+ ,@(map (lambda (import) (element-syntax-syntax import)) imports))
(load-extension "libguile_xcb_expression" "init_xcb_expressions")
(define xcbdoc (make-hash-table))
- ,@(map element-syntax-syntax (append xidtypes xidunions typedefs))
+ ,@(map element-syntax-syntax (append xidtypes xidunions typedefs enums structs))
,@(delete
#f
(map
View
5 srfi/srfi-64.scm
@@ -0,0 +1,5 @@
+(define-module (srfi srfi-64))
+
+(cond-expand-provide (current-module) '(srfi-64))
+
+(include-from-path "/home/mark/source/guile-xcb/srfi/srfi-64/srfi-64-port.scm")
View
1,264 srfi/srfi-64/srfi-64-port.scm
@@ -0,0 +1,1264 @@
+;; Copyright (c) 2012 Sunjoong Lee
+;; Copyright (c) 2005, 2006, 2007 Per Bothner
+;;
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+;;
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+;;
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+;; 2007 Per Bothner original.
+;; 2012 Sunjoong Lee modified to fit Guile 2.0.5.
+
+;; Date: 2012-05-07
+
+;; Porting Tips:
+;; 1. Check required SRFIs;
+;; - most languages support SRFI 0, cond-expand, and SRFI 23, error, I think.
+;; - SRFI 9, define-record-type, is needed but not mandatory.
+;; - SRFI 39, make-parameter, is needed but not mandatory.
+;; - SRFI 34, with-exception-handler, may be need. Read #2 of this tips.
+;; - SRFI 35, Conditions, may be need. Read #6 of this tips.
+;; 2. Check the exception handling method;
+;; - %test-eval macro of this file need to know exception handling method.
+;; - %test-eval macro returns a pair of evaluation value and false value
+;; unless a exception occurs.
+;; - %test-eval macro returns a pair of false value and exception cause
+;; if a exception occurs.
+;; - there are pre-defined %test-eval macros for some languages and SRFI 34.
+;; 3. Check the export method if you make a module;
+;; - this file export procedures and macros using %export macro.
+;; - for example, Guile 2.0.5 need not to export any additional procedure
+;; but Guile 1.8.8 need to export %test-eval for test-assert macro.
+;; 4. Check whether pass the test suite for SRFI 64;
+;; - http://srfi.schemers.org/srfi-64/srfi-64-test.scm is a test suite for
+;; SRFI 64.
+;; - 51 expected passes and 2 expected failures are normal.
+;; - something's wrong if unexpected failure.
+;; 5. Try to include source line numbers when reporting;
+;; - there are pre-defined %->form, %->file and %->line procedures,
+;; these procedures are used in %line procedure, for some languages.
+;; - there are pre-defined %quote macro, this macro used in %line procedure
+;; and some macros like test-assert, for some languages.
+;; - for example, test-assert macro use syntax-case for some languages
+;; like Guile and use %quote macro and %line procedure.
+;; 6. Try to improve a exception trapping procedure;
+;; - there are pre-defined %exception procedure for some languages.
+
+(cond-expand
+ (guile
+ ;; 1. Put these files to srfi and srfi/srfi-64 directories.
+ ;; $ mkdir -p srfi/srfi-64
+ ;; $ cp #(some location)#/srfi-64-port.scm srfi/srfi-64
+ ;; $ cp #(some location)#/srfi-64.scm srfi
+ ;; 2. Use -L and --use-srfi option.
+ ;; $ guile -L `pwd` --use-srfi=64
+ (define-module (srfi srfi-64))
+ ;; %cond-expand-features of Guile 2.0.5 is
+ ;; '(guile guile-2 r5rs
+ ;; srfi-0 srfi-4 srfi-6 srfi-13 srfi-14 srfi-23 srfi-39 srfi-55 srfi-61)
+ (use-modules (srfi srfi-9)
+ ((srfi srfi-35) :select (condition-type?
+ condition?
+ condition-has-type?))
+ ((ice-9 regex) :select (string-match)))
+ (cond-expand
+ (guile-2)
+ (else
+ ;; Guile 1.8 fails the test suite for testing srfi-64 by Donovan Kolbly
+ ;; because of nested block comments used in srfi-64-test.scm file.
+ ;; Comments are comments. So, not problem.
+ (use-modules (ice-9 syncase)))))
+ (kawa
+ (module-compile-options warn-undefined-variable: #t
+ warn-invoke-unknown-method: #t)
+ (provide 'srfi-64))
+ (sisc
+ (require-extension (srfi 9 34 35 39)))
+ (else
+ ;; For Chicken 4.7:
+ ;; 1. Put this file to src directory.
+ ;; $ mkdir src
+ ;; $ cp #(some location)#/srfi-64.scm src
+ ;; 2. Make a new srfi-64.scm file.
+ ;; $ echo \
+ ;; '(module srfi-64 () (import chicken scheme) (include "src/srfi-64"))' \
+ ;; > srfi-64.scm
+ ;; 3. Compile that srfi-64.scm file.
+ ;; $ csc -feature compiling-extension -setup-mode -k -s -O3 -d1 \
+ ;; srfi-64.scm -j srfi-64
+ ;; $ csc -feature compiling-extension -setup-mode -k -s -O3 -d0 \
+ ;; srfi-64.import.scm
+ ;; 4. Use -R option.
+ ;; $ csi -R srfi-64
+ ;;
+ ;; Gambit 4.6.5 fails the test suite for testing srfi-64 by Donovan Kolbly.
+ ;; I suspect dynamic-wind bug of Gambit is cause of it.
+ ;; So, simple test-cases like test-assert, test-equal, test-eqv, test-eq
+ ;; and test-error are available but complex ones like test-group-with-cleanup
+ ;; are faithless on Gambit just now.
+))
+
+(cond-expand
+ (kawa
+ (define-syntax %export
+ (syntax-rules ()
+ ((_ test-begin name ...) (module-export %test-begin name ...)))))
+ (guile
+ (cond-expand
+ (guile-2
+ (define-syntax %export
+ (syntax-rules () ((_ name ...) (export name ...)))))
+ (else
+ (define-syntax %export
+ (syntax-rules ()
+ ((_ name ...)
+ (export %test-begin
+ %test-end
+ %test-assert
+ %test-comp
+ %test-error
+ %test-should-execute
+ %test-eval
+ name ...)))))))
+ (chicken
+ (define-syntax %export
+ (syntax-rules ()
+ ((_ name ...)
+ (export %test-begin
+ %test-end
+ %test-assert
+ %test-comp
+ %test-error
+ %test-should-execute
+ name ...)))))
+ (else
+ (define-syntax %export
+ (syntax-rules () ((_ name ...) (if #f #f))))))
+(%export test-begin ; test-begin must be listed first,
+ test-end ; since in Kawa (at least)
+ test-group ; it is "magic".
+ test-group-with-cleanup
+ test-assert
+ test-equal
+ test-eqv
+ test-eq
+ test-approximate
+ test-error
+ test-read-eval-string
+ test-with-runner
+ test-apply
+ test-match-name
+ test-match-nth
+ test-match-any
+ test-match-all
+ test-skip
+ test-expect-fail
+ test-runner-group-path
+ test-result-kind
+ test-passed?
+ test-result-ref
+ test-result-set!
+ test-result-remove
+ test-result-clear
+ test-log-to-file ; not a part of the specification
+ ;; Misc test-runner functions
+ test-runner?
+ test-runner-current
+ test-runner-get
+ test-runner-simple
+ test-runner-null
+ test-runner-create
+ test-runner-factory
+ test-runner-reset
+ test-runner-test-name
+ ;; test-runner field setter and getter functions
+ ;; - see test-runner record definition:
+ test-runner-pass-count
+ test-runner-pass-count! ; not a part of the specification
+ test-runner-fail-count
+ test-runner-fail-count! ; not a part of the specification
+ test-runner-xpass-count
+ test-runner-xpass-count! ; not a part of the specification
+ test-runner-xfail-count
+ test-runner-xfail-count! ; not a part of the specification
+ test-runner-skip-count
+ test-runner-skip-count! ; not a part of the specification
+ test-runner-group-stack
+ test-runner-group-stack! ; not a part of the specification
+ test-runner-on-test-begin
+ test-runner-on-test-begin!
+ test-runner-on-test-end
+ test-runner-on-test-end!
+ test-runner-on-group-begin
+ test-runner-on-group-begin!
+ test-runner-on-group-end
+ test-runner-on-group-end!
+ test-runner-on-final
+ test-runner-on-final!
+ test-runner-on-bad-count
+ test-runner-on-bad-count!
+ test-runner-on-bad-end-name
+ test-runner-on-bad-end-name!
+ test-result-alist
+ test-result-alist! ; not a part of the specification
+ test-runner-aux-value
+ test-runner-aux-value!
+ ;; default/simple call-back functions,
+ ;; used in default test-runner,
+ ;; but can be called to construct more complex ones.
+ test-on-test-begin-simple
+ test-on-test-end-simple
+ test-on-group-begin-simple
+ test-on-group-end-simple
+ test-on-bad-count-simple
+ test-on-bad-end-name-simple
+ test-on-final-simple)
+
+(cond-expand
+ (srfi-9
+ (define-syntax %record-define
+ (syntax-rules ()
+ ((_ alloc runner? (name index getter setter) ...)
+ (define-record-type
+ <test-runner> (alloc) runner? (name getter setter) ...)))))
+ (else
+ (define-syntax %record-define
+ (syntax-rules ()
+ ((_ alloc runner? (name index getter setter) ...)
+ (begin
+ (define %runner-cookie '<test-runner>)
+ (define (runner? obj)
+ (and (vector? obj)
+ (< 1 (vector-length obj))
+ (eq? (vector-ref obj 0) %runner-cookie)))
+ (define (alloc)
+ (let ((runner (make-vector 23)))
+ (vector-set! runner 0 %runner-cookie)
+ runner))
+ (begin
+ (define (getter runner)
+ (vector-ref runner index)) ...)
+ (begin
+ (define (setter runner value)
+ (vector-set! runner index value)) ...)))))))
+(%record-define
+ %test-runner-alloc test-runner?
+ ;; Cumulate count of all tests that have passed and were expected to.
+ (pass-count 1 test-runner-pass-count test-runner-pass-count!)
+ (fail-count 2 test-runner-fail-count test-runner-fail-count!)
+ (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!)
+ (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!)
+ (skip-count 5 test-runner-skip-count test-runner-skip-count!)
+ (skip-list 6 %test-runner-skip-list %test-runner-skip-list!)
+ (fail-list 7 %test-runner-fail-list %test-runner-fail-list!)
+ ;; Normally #t, except when in a test-apply.
+ (run-list 8 %test-runner-run-list %test-runner-run-list!)
+ (skip-save 9 %test-runner-skip-save %test-runner-skip-save!)
+ (fail-save 10 %test-runner-fail-save %test-runner-fail-save!)
+ (group-stack 11 test-runner-group-stack test-runner-group-stack!)
+ (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!)
+ (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!)
+ ;; Call-back when entering a group. Takes (runner suite-name count).
+ (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!)
+ ;; Call-back when leaving a group.
+ (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!)
+ ;; Call-back when leaving the outermost group.
+ (on-final 16 test-runner-on-final test-runner-on-final!)
+ ;; Call-back when expected number of tests was wrong.
+ (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!)
+ ;; Call-back when name in test=end doesn't match test-begin.
+ (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!)
+ ;; Cumulate count of all tests that have been done.
+ (total-count 19 %test-runner-total-count %test-runner-total-count!)
+ ;; Stack (list) of (count-at-start . expected-count):
+ (count-list 20 %test-runner-count-list %test-runner-count-list!)
+ (result-alist 21 test-result-alist test-result-alist!)
+ ;; Field can be used by test-runner for any purpose.
+ ;; test-runner-simple uses it for a log file.
+ (aux-value 22 test-runner-aux-value test-runner-aux-value!))
+
+(cond-expand
+ (guile
+ (define-syntax %test-eval
+ (syntax-rules ()
+ ((_ expr)
+ (let ((value #f) (excpt #f))
+ (begin
+ (set! value (catch #t
+ (lambda () expr)
+ (lambda (key . arg)
+ (set! excpt (append (list key) arg))
+ #f)))
+ (cons value excpt)))))))
+ (chicken
+ (define-syntax %test-eval
+ (syntax-rules ()
+ ((_ expr)
+ (let ((value #f) (excpt #f))
+ (begin
+ (set! value (condition-case expr
+ (exc () (begin
+ (set! excpt exc)
+ #f))))
+ (cons value excpt)))))))
+ (kawa
+ (define-syntax %test-eval
+ (syntax-rules ()
+ ((_ expr)
+ (let ((value #f) (excpt #f))
+ (begin
+ (set! value (try-catch expr
+ (exc <java.lang.Throwable> (begin
+ (set! excpt exc)
+ #f))))
+ (cons value excpt)))))))
+ (mzscheme
+ (define-syntax %test-eval
+ (syntax-rules ()
+ ((_ expr)
+ (let ((value #f) (excpt #f))
+ (begin
+ (set! value (with-handlers (((lambda (exc) #t)
+ (lambda (exc)
+ (set! excpt exc)
+ #f)))
+ expr))
+ (cons value excpt)))))))
+ ((or srfi-34 gambit)
+ (define-syntax %test-eval
+ (syntax-rules ()
+ ((_ expr)
+ (let ((value #f) (excpt #f))
+ (begin
+ (set! value (with-exception-handler (lambda (exc)
+ (set! excpt exc)
+ #f)
+ (lambda () expr)))
+ (cons value excpt)))))))
+ (else
+ (define-syntax %test-eval
+ (syntax-rules ()
+ ((_ expr)
+ (let ((value #f) (excpt #f))
+ (begin
+ (set! value expr)
+ (cons value excpt))))))))
+
+(cond-expand
+ (guile
+ (define-syntax %quote (syntax-rules () ((_ x) (syntax x)))))
+ (else
+ (define-syntax %quote (syntax-rules () ((_ x) (quote x))))))
+
+(define (%line form)
+ (cond-expand
+ (guile
+ (cond-expand
+ (guile-2
+ (define (%->form form) (datum->syntax form (syntax->datum form))))
+ (else
+ ;; Unlike Guile 2.0, Guile 1.8 does not have syntax->datum and
+ ;; datum->syntax macros. I think there is another method. FIXME.
+ (define (%->form form) #f))))
+ ((or kawa mzscheme)
+ (define (%->form form) (syntax-object->datum form)))
+ (else
+ (define (%->form form) #f))) ; %->form ends here
+
+ (cond-expand
+ (guile
+ (cond-expand
+ (guile-2
+ (define (%->file form)
+ (let ((filename (assq-ref (syntax-source form) 'filename)))
+ (if filename (basename filename) #f))))
+ (else
+ ;; Unlike Guile 2.0, Guile 1.8 does not have syntax-source macro.
+ ;; I think there is another method. FIXME.
+ (define (%->file form) #f))))
+ (kawa
+ (define (%->file form) (syntax-source form)))
+ (mzscheme
+ (define (%->file form)
+ (let ((source (syntax-source form)))
+ (cond ((string? source) source)
+ ((path? source) (path->string source))
+ (else #f)))))
+ (else
+ (define (%->file form) #f))) ; %->file ends here
+
+ (cond-expand
+ (guile
+ (cond-expand
+ (guile-2
+ (define (%->line form)
+ ;; Line-number begins from 1 not 0.
+ (1+ (assq-ref (syntax-source form) 'line))))
+ (else
+ ;; Unlike Guile 2.0, Guile 1.8 does not have syntax-source macro.
+ ;; I think there is another method. FIXME.
+ (define (%->line form) #f))))
+ ((or kawa mzscheme)
+ (define (%->line form) (syntax-line form)))
+ (else
+ (define (%->line form) #f))) ; %->line ends here
+
+ ;; actual definition of %line
+ (let ((source-form (%->form form))
+ (source-file (%->file form))
+ (source-line (%->line form)))
+ (if source-form
+ (cons (cons (%quote source-form) source-form)
+ (if source-file
+ (cons (cons (%quote source-file) source-file)
+ (if source-line
+ (cons (cons (%quote source-line) source-line)
+ '())
+ '()))
+ '()))
+ '())))
+
+(define (%source-line runner)
+ (let ((result (test-result-alist runner)))
+ (let ((file (assq 'source-file result))
+ (line (assq 'source-line result)))
+ (if line
+ (string-append (or file "") ":" (number->string (cdr line)) ": ")
+ ""))))
+
+(define (test-result-ref runner pname . default)
+ (let ((p (assq pname (test-result-alist runner))))
+ (cond ((< 1 (length default))
+ (let ((msg (string-append
+ "Usage: (test-result-ref runner pname) "
+ "or (test-result-ref runner pname default)")))
+ (error msg)))
+ (p (cdr p))
+ ((not (null? default)) (car default))
+ (else #f))))
+
+(define (test-result-set! runner pname value)
+ (let ((alist (test-result-alist runner)))
+ (let ((p (assq pname alist)))
+ (if p
+ (set-cdr! p value)
+ (test-result-alist! runner (cons (cons pname value) alist))))))
+
+(define (test-result-remove runner pname)
+ (let ((alist (test-result-alist runner)))
+ (let ((p (assq pname alist)))
+ (if p
+ (test-result-alist! runner (let loop ((r alist))
+ (if (eq? r p)
+ (cdr r)
+ (cons (car r) (loop (cdr r))))))))))
+
+(define (test-result-clear runner)
+ (test-result-alist! runner '()))
+
+(define (test-runner-test-name runner)
+ (test-result-ref runner 'test-name ""))
+
+(define (test-runner-group-path runner)
+ (reverse (test-runner-group-stack runner)))
+
+(define (test-runner-reset runner)
+ (test-result-alist! runner '())
+ (test-runner-pass-count! runner 0)
+ (test-runner-fail-count! runner 0)
+ (test-runner-xpass-count! runner 0)
+ (test-runner-xfail-count! runner 0)
+ (test-runner-skip-count! runner 0)
+ (%test-runner-total-count! runner 0)
+ (%test-runner-count-list! runner '())
+ (%test-runner-run-list! runner #t)
+ (%test-runner-skip-list! runner '())
+ (%test-runner-fail-list! runner '())
+ (%test-runner-skip-save! runner '())
+ (%test-runner-fail-save! runner '())
+ (test-runner-group-stack! runner '()))
+
+;; Not part of the specification. FIXME
+;; Controls whether a log file is generated.
+(cond-expand
+ (srfi-39
+ (define test-log-to-file (make-parameter #t)))
+ (else
+ (define %log-cookie #t)
+ (define (test-log-to-file . arg)
+ (if (not (null? arg))
+ (if (< 1 (length arg))
+ (error "Usage: (test-log-to-file) or (test-log-to-file value)")
+ (set! %log-cookie (car arg))))
+ %log-cookie)))
+
+(define test-on-test-begin-simple #f)
+(define test-on-test-end-simple #f)
+(let ()
+ (define (%display pair port)
+ (display " " port)
+ (display (car pair) port)
+ (display ": " port)
+ (write (cdr pair) port)
+ (newline port)) ; %display ends here
+
+ ;; actual definition of test-on-test-begin-simple
+ (set!
+ test-on-test-begin-simple
+ (lambda (runner)
+ (let ((log (test-runner-aux-value runner)))
+ (if (output-port? log)
+ (let ((results (test-result-alist runner)))
+ (let ((file (assq 'source-file results))
+ (line (assq 'source-line results))
+ (form (assq 'source-form results))
+ (name (assq 'test-name results)))
+ (display "Test begin:" log)
+ (newline log)
+ (if name (%display name log))
+ (if file (%display file log))
+ (if line (%display line log))
+ (if form (%display form log))))))))
+
+ ;; actual definition of test-on-test-end-simple
+ (set!
+ test-on-test-end-simple
+ (lambda (runner)
+ (let ((log (test-runner-aux-value runner))
+ (kind (test-result-ref runner 'result-kind)))
+ (if (output-port? log)
+ (begin
+ (display "Test end:" log)
+ (newline log)
+ (let loop ((alist (test-result-alist runner)))
+ (if (pair? alist)
+ (let ((pair (car alist)))
+ ;; Write out properties not written out by on-test-begin.
+ (if (not
+ (memq
+ (car pair)
+ '(test-name source-file source-line source-form)))
+ (%display pair log))
+ (loop (cdr alist)))))))
+ (if (memq kind '(fail xpass))
+ (let ((results (test-result-alist runner)))
+ (let ((source-file (assq 'source-file results))
+ (source-line (assq 'source-line results))
+ (test-name (assq 'test-name results)))
+ (if (or source-file source-line)
+ (begin
+ (if source-file (display (cdr source-file)))
+ (display ":")
+ (if source-line (display (cdr source-line)))
+ (display ": ")
+ (display (if (eq? kind 'xpass) "XPASS" "FAIL"))
+ (if test-name
+ (begin (display " ") (display (cdr test-name))))
+ (newline))))))
+ kind))))
+
+(define (test-on-group-begin-simple runner suite-name count)
+ (if (null? (test-runner-group-stack runner))
+ (begin
+ (display "%%%% Starting test ")
+ (display suite-name)
+ (let ((log-file (if (procedure? test-log-to-file)
+ (test-log-to-file)
+ test-log-to-file)))
+ (if log-file
+ (begin
+ (if (not (output-port? log-file))
+ (let ((log-file-name (if (string? test-log-to-file)
+ test-log-to-file
+ (string-append
+ suite-name ".log"))))
+ (cond-expand
+ (mzscheme
+ (set! log-file
+ (open-output-file log-file-name
+ 'truncate/replace)))
+ (guile-2
+ (set! log-file
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (open-output-file log-file-name))))
+ (else
+ (set! log-file (open-output-file log-file-name))))
+ (display " (Writing full log to \"")
+ (display log-file-name)
+ (display "\")")))
+ (test-runner-aux-value! runner log-file)
+ (display "%%%% Starting test " log-file)
+ (display suite-name log-file)
+ (newline log-file))))
+ (newline)))
+ (let ((log (test-runner-aux-value runner)))
+ (if (output-port? log)
+ (begin
+ (display "Group begin: " log)
+ (display suite-name log)
+ (newline log)))))
+
+(define (test-on-group-end-simple runner)
+ (let ((log (test-runner-aux-value runner)))
+ (if (output-port? log)
+ (begin
+ (display "Group end: " log)
+ (display (car (test-runner-group-stack runner)) log)
+ (newline log)))))
+
+(define (test-on-final-simple runner)
+ (let ((log (test-runner-aux-value runner))
+ (pass-count (test-runner-pass-count runner))
+ (xfail-count (test-runner-xfail-count runner))
+ (xpass-count (test-runner-xpass-count runner))
+ (fail-count (test-runner-fail-count runner))
+ (skip-count (test-runner-skip-count runner)))
+ (define (%display port)
+ (define (%display-if value label port)
+ (if (> value 0)
+ (begin
+ (display label port)
+ (display value port)
+ (newline port))))
+ ;; actual definition of %display
+ (%display-if pass-count "# of expected passes " port)
+ (%display-if xfail-count "# of expected failures " port)
+ (%display-if xpass-count "# of unexpected successes " port)
+ (%display-if fail-count "# of unexpected failures " port)
+ (%display-if skip-count "# of skipped tests " port))
+
+ ;; actual definition of test-on-final-simple
+ (if (output-port? log)
+ (begin
+ (%display log)
+ (if (or (and (procedure? test-log-to-file)
+ (not (output-port? (test-log-to-file))))
+ (not (output-port? test-log-to-file)))
+ (close-output-port log))))
+ (%display (current-output-port))
+ (list pass-count xfail-count xpass-count fail-count skip-count)))
+
+(define (test-on-bad-count-simple runner count expected-count)
+ (define (%display count expected-count port)
+ (display "*** Total number of tests was " port)
+ (display count port)
+ (display " but should be " port)
+ (display expected-count port)
+ (display ". ***" port)
+ (display
+ "*** Discrepancy indicates testsuite error or exceptions. ***" port)
+ (newline port)) ; %display ends here
+
+ ;; actual definition of test-on-bad-count-simple
+ (let ((log (test-runner-aux-value runner)))
+ (if (output-port? log)
+ (%display count expected-count log))
+ (%display count expected-count (current-output-port))))
+
+(define (test-on-bad-end-name-simple runner begin-name end-name)
+ (let ((msg (string-append
+ (%source-line runner) "test-end " begin-name
+ " does not match test-begin " end-name)))
+ (error msg)))
+
+(cond-expand
+ (srfi-39
+ (define test-runner-current (make-parameter #f)))
+ (else
+ (define %current-cookie #f)
+ (define (test-runner-current . arg)
+ (if (not (null? arg))
+ (if (< 1 (length arg))
+ (let ((msg (string-append
+ "Usage: (test-runner-current) "
+ "or (test-runner-current runner)")))
+ (error msg))
+ (set! %current-cookie (car arg))))
+ %current-cookie)))
+;; A safer wrapper to test-runner-current.
+(define (test-runner-get)
+ (let ((runner (test-runner-current)))
+ (if (not runner)
+ (error "test-runner not initialized - test-begin missing?"))
+ runner))
+
+(define (test-runner-simple)
+ (let ((runner (%test-runner-alloc)))
+ (test-runner-reset runner)
+ (test-runner-on-test-begin! runner test-on-test-begin-simple)
+ (test-runner-on-test-end! runner test-on-test-end-simple)
+ (test-runner-on-group-begin! runner test-on-group-begin-simple)
+ (test-runner-on-group-end! runner test-on-group-end-simple)
+ (test-runner-on-final! runner test-on-final-simple)
+ (test-runner-on-bad-count! runner test-on-bad-count-simple)
+ (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
+ runner))
+
+(define (test-runner-null)
+ (let ((runner (%test-runner-alloc)))
+ (test-runner-reset runner)
+ (test-runner-on-test-begin! runner (lambda (runner) #f))
+ (test-runner-on-test-end! runner (lambda (runner) #f))
+ (test-runner-on-group-begin! runner (lambda (runner name count) #f))
+ (test-runner-on-group-end! runner (lambda (runner) #f))
+ (test-runner-on-final! runner (lambda (runner) #f))
+ (test-runner-on-bad-count! runner (lambda (runner count expected) #f))
+ (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f))
+ runner))
+
+(cond-expand
+ (srfi-39
+ (define test-runner-factory (make-parameter test-runner-simple)))
+ (else
+ (define %factory-cookie test-runner-simple)
+ (define (test-runner-factory . arg)
+ (if (not (null? arg))
+ (if (< 1 (length arg))
+ (let ((msg (string-append
+ "Usage: (test-runner-factory) "
+ "or (test-runner-factory factory)")))
+ (error msg))
+ (set! %factory-cookie (car arg))))
+ %factory-cookie)))
+(define (test-runner-create)
+ ((test-runner-factory)))
+
+(define (test-result-kind . rest)
+ (let ((runner (if (pair? rest) (car rest) (test-runner-current))))
+ (test-result-ref runner 'result-kind)))
+
+(define (test-passed? . rest)
+ (let ((runner (if (pair? rest) (car rest) (test-runner-get))))
+ (memq (test-result-ref runner 'result-kind) '(pass xpass))))
+
+(define (test-match-name name)
+ (lambda (runner)
+ (equal? name (test-runner-test-name runner))))
+
+(define (test-match-nth n . count)
+ (let ((i 0) (kount (if (null? count) 1 (car count))))
+ (if (< 1 (length count))
+ (error "Usage: (test-match-nth n) or (test-match-nth n count)")
+ (lambda (runner)
+ (set! i (+ i 1))
+ (and (>= i n) (< i (+ n kount)))))))
+
+(define test-match-any #f)
+(define test-match-all #f)
+(define test-skip #f)
+(define test-expect-fail #f)
+(define %test-should-execute #f)
+(let ()
+ (define (%any . pred-list)
+ (lambda (runner)
+ (let ((result #f))
+ (let loop ((lst pred-list))
+ (if (null? lst)
+ result
+ (begin
+ (if ((car lst) runner)
+ (set! result #t))
+ (loop (cdr lst)))))))) ; %any ends here
+
+ (define (%all . pred-list)
+ (lambda (runner)
+ (let ((result #t))
+ (let loop ((lst pred-list))
+ (if (null? lst)
+ result
+ (begin
+ (if (not ((car lst) runner))
+ (set! result #f))
+ (loop (cdr lst)))))))) ; %all ends here
+
+ (define (%specifier specifier)
+ (cond ((procedure? specifier) specifier)
+ ((integer? specifier) (test-match-nth 1 specifier))
+ ((string? specifier) (test-match-name specifier))
+ (else
+ (error "not a valid test specifier")))) ; %specifier ends here
+
+ ;; actual definition of test-match-any
+ (set!
+ test-match-any
+ (lambda (pred . args)
+ (apply %any (%specifier pred) args)))
+
+ ;; actual definition of test-match-all
+ (set!
+ test-match-all
+ (lambda (pred . args)
+ (apply %all (%specifier pred) args)))
+
+ ;; actual definition of test-skip
+ (set!
+ test-skip
+ (lambda (pred . args)
+ (let ((runner (test-runner-get)))
+ (%test-runner-skip-list! runner
+ (cons (apply
+ test-match-all (%specifier pred) args)
+ (%test-runner-skip-list runner))))))
+
+ ;; actual definition of test-expect-fail
+ (set!
+ test-expect-fail
+ (lambda (pred . args)
+ (let ((runner (test-runner-get)))
+ (%test-runner-fail-list! runner
+ (cons (apply
+ test-match-all (%specifier pred) args)
+ (%test-runner-fail-list runner))))))
+
+ ;; actual definition of %test-should-execute
+ (set!
+ ;; Returns #f, #t, or 'xfail.
+ %test-should-execute
+ (lambda (runner)
+ (let ((run-list (%test-runner-run-list runner)))
+ (cond ((or (not (or (eqv? run-list #t)
+ ((apply %any run-list) runner)))
+ ((apply %any (%test-runner-skip-list runner)) runner))
+ (test-result-set! runner 'result-kind 'skip)
+ #f)
+ (((apply %any (%test-runner-fail-list runner)) runner)
+ (test-result-set! runner 'result-kind 'xfail)
+ 'xfail)
+ (else #t))))))
+
+(define-syntax test-with-runner
+ (syntax-rules ()
+ ((test-with-runner runner form ...)
+ (let ((saved-runner (test-runner-current)))
+ (dynamic-wind
+ (lambda () (test-runner-current runner))
+ (lambda () form ...)
+ (lambda () (test-runner-current saved-runner)))))))
+
+(define (test-apply first . rest)
+ (if (test-runner? first)
+ (test-with-runner first (apply test-apply rest))
+ (let ((runner (test-runner-current)))
+ (if runner
+ (let ((run-list (%test-runner-run-list runner)))
+ (cond ((null? rest)
+ (%test-runner-run-list! runner (reverse run-list))
+ (first)) ; actually apply procedure thunk
+ (else
+ (%test-runner-run-list!
+ runner
+ (if (eq? run-list #t) (list first) (cons first run-list)))
+ (apply test-apply rest)
+ (%test-runner-run-list! runner run-list))))
+ (let ((runner (test-runner-create)))
+ (test-with-runner runner (apply test-apply first rest))
+ ((test-runner-on-final runner) runner))))))
+
+(define (%test-begin suite-name . count)
+ (if (not (test-runner-current)) (test-runner-current (test-runner-create)))
+ (if (< 1 (length count))
+ (error "Usage: (test-begin suite-name) or (test-begin suite-name count)"))
+ (let ((runner (test-runner-current))
+ (kount (if (null? count) #f (car count))))
+ ((test-runner-on-group-begin runner) runner suite-name kount)
+ (%test-runner-skip-save! runner
+ (cons (%test-runner-skip-list runner)
+ (%test-runner-skip-save runner)))
+ (%test-runner-fail-save! runner
+ (cons (%test-runner-fail-list runner)
+ (%test-runner-fail-save runner)))
+ (%test-runner-count-list! runner
+ (cons (cons (%test-runner-total-count runner)
+ kount)
+ (%test-runner-count-list runner)))
+ (test-runner-group-stack! runner
+ (cons suite-name
+ (test-runner-group-stack runner)))))
+(cond-expand
+ (kawa
+ ;; Kawa has test-begin built in, implemented as:
+ ;; (begin
+ ;; (cond-expand (srfi-64 #!void) (else (require 'srfi-64)))
+ ;; (%test-begin suite-name [count]))
+ ;; This puts test-begin but only test-begin in the default environment.,
+ ;; which makes normal test suites loadable without non-portable commands.
+ )
+ (else
+ (define test-begin %test-begin)))
+
+(define (%test-end suite-name line)
+ (let ((runner (test-runner-get)))
+ (test-result-alist! runner line)
+ (let ((groups (test-runner-group-stack runner))
+ (count-list (%test-runner-count-list runner)))
+ (if (null? groups)
+ (let ((msg (string-append
+ (%source-line runner) "test-end not in a group")))
+ (error msg)))
+ (if (and suite-name (not (equal? suite-name (car groups))))
+ ((test-runner-on-bad-end-name runner) runner suite-name (car groups)))
+ (let ((expected-count (cdar count-list))
+ (saved-count (caar count-list)))
+ (let ((group-count (- (%test-runner-total-count runner) saved-count)))
+ (if (and expected-count (not (= expected-count group-count)))
+ ((test-runner-on-bad-count runner) runner
+ group-count expected-count))
+ ((test-runner-on-group-end runner) runner)
+ (test-runner-group-stack! runner
+ (cdr (test-runner-group-stack runner)))
+ (%test-runner-skip-list! runner
+ (car (%test-runner-skip-save runner)))
+ (%test-runner-skip-save! runner
+ (cdr (%test-runner-skip-save runner)))
+ (%test-runner-fail-list! runner
+ (car (%test-runner-fail-save runner)))
+ (%test-runner-fail-save! runner
+ (cdr (%test-runner-fail-save runner)))
+ (%test-runner-count-list! runner (cdr count-list))
+ (if (null? (test-runner-group-stack runner))
+ ((test-runner-on-final runner) runner)))))))
+
+(define %test-assert #f)
+(define %test-comp #f)
+(define %test-error #f)
+(let ()
+ (define (%begin runner)
+ (%test-should-execute runner)
+ ((test-runner-on-test-begin runner) runner)
+ (not (eq? 'skip (test-result-ref runner 'result-kind))))
+
+ (define (%end runner result)
+ (test-result-set! runner
+ 'result-kind
+ (if (eq? (test-result-ref runner 'result-kind) 'xfail)
+ (if result 'xpass 'xfail)
+ (if result 'pass 'fail))))
+
+ (define (%report runner kind)
+ (case kind
+ ((pass)
+ (test-runner-pass-count! runner
+ (+ 1 (test-runner-pass-count runner))))
+ ((fail)
+ (test-runner-fail-count! runner
+ (+ 1 (test-runner-fail-count runner))))
+ ((xpass)
+ (test-runner-xpass-count! runner
+ (+ 1 (test-runner-xpass-count runner))))
+ ((xfail)
+ (test-runner-xfail-count! runner
+ (+ 1 (test-runner-xfail-count runner))))
+ (else
+ (test-runner-skip-count! runner
+ (+ 1 (test-runner-skip-count runner)))))
+ (%test-runner-total-count! runner
+ (+ 1 (%test-runner-total-count runner)))
+ ((test-runner-on-test-end runner) runner))
+
+ ;; actual definition of %test-assert
+ (set!
+ %test-assert
+ (lambda (eval-pair line)
+ (let ((runner (test-runner-get))
+ (value (car eval-pair))
+ (excpt (cdr eval-pair)))
+ (test-result-alist! runner line)
+ (if (%begin runner)
+ (if excpt
+ (begin
+ (test-result-set! runner 'actual-error excpt)
+ (%end runner #f))
+ (begin
+ (test-result-set! runner 'actual-value value)
+ (%end runner value))))
+ (%report runner (test-result-ref runner 'result-kind)))))
+
+ ;; actual definition of %test-comp
+ (set!
+ %test-comp
+ (lambda (pred-or-error expected eval-pair line)
+ (let ((runner (test-runner-get))
+ (value (car eval-pair))
+ (excpt (cdr eval-pair)))
+ (test-result-alist! runner line)
+ (if (%begin runner)
+ (begin
+ (test-result-set! runner 'expected-value expected)
+ (if excpt
+ (begin
+ (test-result-set! runner 'actual-error excpt)
+ (%end runner #f))
+ (begin
+ (test-result-set! runner 'actual-value value)
+ (%end runner (if (procedure? pred-or-error)
+ (pred-or-error expected value)
+ (and (>= value
+ (- expected pred-or-error))
+ (<= value
+ (+ expected pred-or-error)))))))))
+ (%report runner (test-result-ref runner 'result-kind)))))
+
+ ;; definition of %test-error
+ (set!
+ %test-error
+ (lambda (etype eval-pair line)
+ (let ((runner (test-runner-get))
+ (value (car eval-pair))
+ (excpt (cdr eval-pair)))
+ (cond-expand
+ (guile
+ (define (%exception)
+ (let ((key (car excpt)) (args (cdr excpt)))
+ (cond ((or (and (boolean? etype) etype) (equal? etype key))
+ #t)
+ ((string? etype)
+ (if (null? args)
+ (string-match etype key)
+ (let ((message (cadr args)))
+ (cond ((string-match etype message)
+ #t)
+ ((< 2 (length args))
+ (string-match
+ etype
+ (apply
+ simple-format #f message (caddr args))))
+ (else #f)))))
+ ((procedure? etype)
+ (etype excpt))
+ ((condition-type? etype)
+ (and (condition? excpt) (condition-has-type? excpt etype)))
+ (else #f)))))
+ (kawa
+ (define (%exception)
+ (cond ((or (and (boolean? etype) etype) (equal? etype excpt))
+ #t)
+ ((and (instance? etype <gnu.bytecode.ClassType>)
+ (gnu.bytecode.ClassType:isSubclass
+ etype
+ <java.lang.Throwable>))
+ (instance? excpt etype))
+ (else #f))))
+ (srfi-35
+ (define (%exception)
+ (cond ((or (and (boolean? etype) etype) (equal? etype excpt))
+ #t)
+ ((procedure? etype)
+ (etype excpt))
+ ((condition-type? etype)
+ (and (condition? excpt) (condition-has-type? excpt etype)))
+ (else #f))))
+ (else
+ (define (%exception)
+ (cond ((or (and (boolean? etype) etype) (equal? etype excpt))
+ #t)
+ ((procedure? etype)
+ (etype excpt))
+ (else #f))))) ; %exception ends here
+
+ ;; actual definition of %test-error
+ (test-result-alist! runner line)
+ (if (%begin runner)
+ (begin
+ (test-result-set! runner 'expected-error etype)
+ (if excpt
+ (begin
+ (test-result-set! runner 'actual-error excpt)
+ (%end runner (%exception)))
+ (begin
+ (test-result-set! runner 'actual-value value)
+ (%end runner #f)))))
+ (%report runner (test-result-ref runner 'result-kind))))))
+
+(cond-expand
+ (guile
+ (define (test-read-eval-string string)
+ (let ((port (open-input-string string)))
+ (let ((form (read port)))
+ (if (eof-object? (read-char port))
+ (primitive-eval form)
+ (error "(not at eof)"))))))
+ (else
+ (define (test-read-eval-string string)
+ (let ((port (open-input-string string)))
+ (let ((form (read port)))
+ (if (eof-object? (read-char port))
+ (eval form)
+ (error "(not at eof)")))))))
+
+(cond-expand
+ ((or guile kawa mzscheme)
+ (define-syntax test-end
+ (lambda (x)
+ (syntax-case (list x (list (%quote quote) (%line x))) ()
+ (((_) line)
+ (syntax (%test-end #f line)))
+ (((_ suite-name) line)
+ (syntax (%test-end suite-name line)))))))
+ (else
+ (define-syntax test-end
+ (syntax-rules ()
+ ((_)
+ (%test-end #f '()))
+ ((_ suite-name)
+ (%test-end suite-name '()))))))
+
+(define-syntax test-group
+ (syntax-rules ()
+ ((test-group suite-name . body)
+ (let ((runner (test-runner-current)))
+ ;; Ideally should also set line-number, if available.
+ (test-result-alist! runner (list (cons 'test-name suite-name)))
+ (if (%test-should-execute runner)
+ (dynamic-wind
+ (lambda () (test-begin suite-name))
+ (lambda () . body)
+ (lambda () (test-end suite-name))))))))
+
+(define-syntax test-group-with-cleanup
+ (syntax-rules ()
+ ((test-group-with-cleanup suite-name form cleanup-form)
+ (test-group suite-name
+ (dynamic-wind
+ (lambda () #f)
+ (lambda () form)
+ (lambda () cleanup-form))))
+ ((test-group-with-cleanup suite-name cleanup-form)
+ (test-group-with-cleanup suite-name #f cleanup-form))
+ ((test-group-with-cleanup suite-name form1 form2 form3 . rest)
+ (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest))))
+
+(cond-expand
+ ((or guile kawa mzscheme)
+ (define-syntax test-assert
+ (lambda (x)
+ (syntax-case (list x (list (%quote quote) (%line x))) ()
+ (((_ name expr) line)
+ (syntax
+ (%test-assert (%test-eval expr) (cons (cons 'test-name name) line))))
+ (((_ expr) line)
+ (syntax (%test-assert (%test-eval expr) line)))))))
+ (else
+ (define-syntax test-assert
+ (syntax-rules ()
+ ((_ name expr)
+ (%test-assert (%test-eval expr) (cons (cons 'test-name name) '())))
+ ((_ expr)
+ (%test-assert (%test-eval expr) '()))))))
+
+(cond-expand
+ ((or guile kawa mzscheme)
+ (define-syntax test-equal
+ (lambda (x)
+ (syntax-case (list x (list (%quote quote) (%line x))) ()
+ (((_ name expected expr) line)
+ (syntax
+ (%test-comp equal? expected (%test-eval expr)
+ (cons (cons 'test-name name) line))))
+ (((_ expected expr) line)
+ (syntax (%test-comp equal? expected (%test-eval expr) line)))))))
+ (else
+ (define-syntax test-equal
+ (syntax-rules ()
+ ((_ name expected expr)
+ (%test-comp equal? expected (%test-eval expr)
+ (cons (cons 'test-name name) '())))
+ ((_ expected expr)
+ (%test-comp equal? expected (%test-eval expr) '()))))))
+
+(cond-expand
+ ((or guile kawa mzscheme)
+ (define-syntax test-eqv
+ (lambda (x)
+ (syntax-case (list x (list (%quote quote) (%line x))) ()
+ (((_ name expected expr) line)
+ (syntax
+ (%test-comp eqv? expected (%test-eval expr)
+ (cons (cons 'test-name name) line))))
+ (((_ expected expr) line)
+ (syntax (%test-comp eqv? expected (%test-eval expr) line)))))))
+ (else
+ (define-syntax test-eqv
+ (syntax-rules ()
+ ((_ name expected expr)
+ (%test-comp eqv? expected (%test-eval expr)
+ (cons (cons 'test-name name) '())))
+ ((_ expected expr)
+ (%test-comp eqv? expected (%test-eval expr) '()))))))
+
+(cond-expand
+ ((or guile kawa mzscheme)
+ (define-syntax test-eq
+ (lambda (x)
+ (syntax-case (list x (list (%quote quote) (%line x))) ()
+ (((_ name expected expr) line)
+ (syntax
+ (%test-comp eq? expected (%test-eval expr)
+ (cons (cons 'test-name name) line))))
+ (((_ expected expr) line)
+ (syntax (%test-comp eq? expected (%test-eval expr) line)))))))
+ (else
+ (define-syntax test-eq
+ (syntax-rules ()
+ ((_ name expected expr)
+ (%test-comp eq? expected (%test-eval expr)
+ (cons (cons 'test-name name) '())))
+ ((_ expected expr)
+ (%test-comp eq? expected (%test-eval expr) '()))))))
+
+(cond-expand
+ ((or guile kawa mzscheme)
+ (define-syntax test-approximate
+ (lambda (x)
+ (syntax-case (list x (list (%quote quote) (%line x))) ()
+ (((_ name expected expr err) line)
+ (syntax
+ (%test-comp err expected (%test-eval expr)
+ (cons (cons 'test-name name) line))))
+ (((_ expected expr err) line)
+ (syntax (%test-comp err expected (%test-eval expr) line)))))))
+ (else
+ (define-syntax test-approximate
+ (syntax-rules ()
+ ((_ name expected expr err)
+ (%test-comp err expected (%test-eval expr)
+ (cons (cons 'test-name name) '())))
+ ((_ expected expr err)
+ (%test-comp err expected (%test-eval expr) '()))))))
+
+(cond-expand
+ ((or guile kawa mzscheme)
+ (define-syntax test-error
+ (lambda (x)
+ (syntax-case (list x (list (%quote quote) (%line x))) ()
+ (((_ name etype expr) line)
+ (syntax
+ (%test-error etype (%test-eval expr)
+ (cons (cons 'test-name name) line))))
+ (((_ etype expr) line)
+ (syntax (%test-error etype (%test-eval expr) line)))
+ (((_ expr) line)
+ (syntax (%test-error #t (%test-eval expr) line)))))))
+ (else
+ (define-syntax test-error
+ (syntax-rules ()
+ ((_ name etype expr)
+ (%test-error etype (%test-eval expr) (cons (cons 'test-name name) '())))
+ ((_ etype expr)
+ (%test-error etype (%test-eval expr) '()))
+ ((_ expr)
+ (%test-error #t (%test-eval expr) '()))))))
View
24 xcb/xml/common.scm
@@ -2,33 +2,11 @@
#:use-module (srfi srfi-2)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-9 gnu)
- #:use-module (ice-9 regex)
- #:export (typed-value
- typed-value-predicate
- typed-value-value
- typed-value?
- make-typed-value))
+ #:use-module (ice-9 regex))
(define hex-integer-regexp "^0x[0-9a-fA-F]+$")
(define xml-integer-regexp "^[-+]?[0-9]+$")
-(define-record-type typed-value
- (make-typed-value value predicate)
- typed-value?
- (value typed-value-value)
- (predicate typed-value-predicate))
-
-(set-record-type-printer!
- typed-value
- (lambda (value port)
- (format
- port "<~a: ~a>"
- (procedure-name (typed-value-predicate value))
- (typed-value-value value))))
-
-(define-public (typed-value-check val)
- ((typed-value-predicate val) val))
-
(define-once documentation (make-hash-table))
(define (hash-force-nested-set! h keys value)
View
21 xcb/xml/enum.scm
@@ -0,0 +1,21 @@
+(define-module (xcb xml enum)
+ #:use-module (srfi srfi-9))
+
+(define-record-type xcb-enum
+ (make-xcb-enum-internal key-value-hash value-key-hash)
+ xcb-enum?
+ (key-value-hash key-value-hash)
+ (value-key-hash value-key-hash))
+
+(define-public (make-xcb-enum)
+ (make-xcb-enum-internal (make-hash-table) (make-hash-table)))
+
+(define-public (xcb-enum-set! enum key val)
+ (hashq-set! (key-value-hash enum) key val)
+ (hashq-set! (value-key-hash enum) val key))
+
+(define-public (xcb-enum-get enum key)
+ (hashq-ref (key-value-hash enum) key))
+
+(define-public (xcb-enum-key-get enum val)
+ (hashq-ref (value-key-hash enum) val))
View
9 xcb/xml/ext/xproto.scm
@@ -0,0 +1,9 @@
+(define-module (xcb xml ext xproto)
+ #:use-module (system base compile)
+ #:use-module (language xml-xcb spec)
+ #:use-module (xcb xml type)
+ #:use-module (xcb xml struct)
+ #:use-module (xcb xml enum)
+ #:use-module (xcb xml common))
+
+(compile-and-load "/home/mark/source/guile-xcb/test.xml" #:from xml-xcb)
View
282 xcb/xml/struct.scm
@@ -3,12 +3,42 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-2)
#:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 receive)
#:use-module (xcb xml type)
+ #:use-module (xcb xml enum)
#:use-module ((rnrs base) #:select (vector-for-each))
- #:export (define-xcb-struct))
+ #:export (define-xcb-struct
+ underlying-record-type
+ xcb-struct?
+ types
+ xcb-struct-pack
+ resolve-type
+ xcb-struct-unpack))
(load-extension "libguile_xcb_expression" "init_xcb_expressions")
+(define (resolve-type type mask enum require-enum?)
+ (let ((base-type
+ (cond
+ ((xcb-struct? type)
+ (xcb-type-for-struct type))
+ ((xcb-type? type)
+ type)
+ (else
+ (error "xml-xcb: Cannnot determine type name for " type)))))
+ (cond
+ (enum (enum-type base-type enum require-enum?))
+ (mask (mask-type base-type mask))
+ (else base-type))))
+
+(define (xcb-type-for-struct xcb-struct)
+ (make-xcb-type
+ (symbol-append (record-type-name (underlying-record-type xcb-struct)) '-type)
+ (type-predicate (record-predicate (underlying-record-type xcb-struct)))
+ (lambda (port rec) (xcb-struct-pack xcb-struct rec port))
+ (lambda (port) (xcb-struct-unpack xcb-struct 0 port))
+ #f))
+
(define-record-type xcb-struct-type
(make-xcb-struct
underlying-record-type
@@ -25,27 +55,36 @@
(list-length-expressions list-length-expressions)
(field-order field-order))
+(define-public (xcb-struct-name xcb-struct)
+ (record-type-name (underlying-record-type xcb-struct)))
+
+(define-public (xcb-struct-predicate xcb-struct)
+ (record-predicate (underlying-record-type xcb-struct)))
+
(define-syntax define-xcb-struct
(syntax-rules ()
((define-xcb-struct type
- (constructor constructor-tag ...)
- predicate
- switch-expression
- (field-tag xcb-type . more) ...)
+ (constructor constructor-tag ...)
+ predicate
+ type-name
+ switch-expression
+ (field-tag xcb-type . more) ...)
(begin
- (define type
- (make-xcb-struct-for-record-type
- 'type
- switch-expression
- (list
- (xcb-struct-field-specifier
- field-tag xcb-type . more) ...)))
- (define constructor
- (xcb-struct-constructor type '(constructor-tag ...)))
- (define predicate
- (xcb-struct-predicate type))
- (define-xcb-struct-field type field-tag xcb-type . more)
- ...))))
+ (define-public type
+ (make-xcb-struct-for-record-type
+ 'type
+ switch-expression
+ (list
+ (xcb-struct-field-specifier
+ field-tag xcb-type . more) ...)))
+ (define-public constructor
+ (xcb-struct-constructor type '(constructor-tag ...)))
+ (define-public predicate
+ (xcb-struct-predicate type))
+ (define-public type-name
+ (xcb-type-for-struct type))
+ (define-xcb-struct-field type field-tag xcb-type . more)
+ ...))))
(define-syntax xcb-struct-field-specifier
(syntax-rules (*list* *pad* *expr*)
@@ -63,21 +102,21 @@
(define-syntax define-xcb-struct-field
(syntax-rules (*list* *pad* *expr*)
((define-xcb-struct-field type field-tag xcb-type accessor)
- (define accessor (xcb-struct-accessor type 'field-tag)))
+ (define-public accessor (xcb-struct-accessor type 'field-tag)))
((define-xcb-struct-field type field-tag xcb-type accessor modifier)
(begin
(begin
- (define accessor (xcb-struct-accessor type 'field-tag))
- (define modifier (xcb-struct-modifier type 'field-tag)))))
+ (define-public accessor (xcb-struct-accessor type 'field-tag))
+ (define-public modifier (xcb-struct-modifier type 'field-tag)))))
((define-xcb-struct-field type field-tag xcb-type *list* list-length-expression
accessor modifier)
(begin
- (define accessor
- (if (list-length-expression)
+ (define-public accessor
+ (if list-length-expression
(xcb-struct-vector-accessor type 'field-tag)
(xcb-struct-accessor type 'field-tag)))
- (define modifier
- (if (list-length-expression)
+ (define-public modifier
+ (if list-length-expression
(xcb-struct-vector-modifier type 'field-tag)
(xcb-struct-modifier type 'field-tag)))))
((define-xcb-struct-field type *pad* size) *unspecified*)
@@ -126,7 +165,8 @@
(define (xcb-struct-field-ref-proc xcb-struct rec)
"Returns a procedure that will return the value for FIELD in the given REC. If FIELD is not present in REC, it will check to see if FIELD is actually in the form LIST_len, and if so, return the length of list LIST in REC"
(lambda (field)
- (if (find (lambda (check-field) (eq? check-field field)) record-type-fields)
+ (if (find (lambda (check-field) (eq? check-field field))
+ (record-type-fields (underlying-record-type xcb-struct)))
(typed-value-value ((record-accessor (underlying-record-type xcb-struct) field) rec))
(if (string= (string-take-right (symbol->string field) 4) "_len")
(let ((field (string->symbol (string-drop-right (symbol->string field) 4))))
@@ -144,24 +184,37 @@
(lambda args
(let ((rec
(apply
- (record-constructor (underlying-record-type xcb-struct)
- (append
- fields
- (if (switch xcb-struct)
- (map car (xcb-switch-fields (switch xcb-struct))) '())))
+ (record-constructor
+ (underlying-record-type xcb-struct)
+ (append
+ fields
+ (if (switch xcb-struct)
+ (map car (xcb-switch-fields (switch xcb-struct))) '())))
(append
(map
(lambda (arg field)
- (if (typed-value? arg)
- (typecheck arg)
- (typecheck (make-typed-value arg (hashq-ref (types xcb-struct) field)))))
+ (let* ((xcb-type (hashq-ref (types xcb-struct) field))
+ (checked-val (if (xcb-type-enum xcb-type)
+ (or (xcb-enum-get (xcb-type-enum xcb-type) arg)
+ (if (xcb-type-require-enum? xcb-type)
+ (error "xcb-xml: No enum value with name " arg)
+ arg))
+ arg)))
+ (if (typed-value? checked-val)
+ (typecheck checked-val)
+ (typecheck (make-typed-value
+ checked-val
+ (hashq-ref (types xcb-struct) field))))))
args fields)
(if (switch xcb-struct) (map car (xcb-switch-fields (switch xcb-struct))) '())))))
(for-each (lambda (field)
((record-modifier (underlying-record-type xcb-struct) field) rec
(make-vector
((hashq-ref (list-length-expressions xcb-struct) field)
- (xcb-struct-field-ref-proc xcb-struct rec)))))
+ (xcb-struct-field-ref-proc xcb-struct rec))
+ (if (xcb-type-mask
+ (hashq-ref (types xcb-struct) field))
+ (make-typed-value 0 (hashq-ref (types xcb-struct) field))))))
list-fields)
rec))))
@@ -185,19 +238,67 @@
(typed-value-value value)))))
(define (xcb-struct-vector-modifier xcb-struct field-tag)
- (lambda (rec n arg)
- (let ((val
- (if (typed-value? arg)
- (typecheck arg)
- (typecheck (make-typed-value arg (hashq-ref (types xcb-struct) field-tag))))))
- (vector-set! ((xcb-struct-accessor xcb-struct field-tag) rec) n val))))
+ (lambda* (rec n arg #:optional (t-or-f *unspecified*))
+ (if (and (not (eq? t-or-f *unspecified*))
+ (xcb-type-mask (hashq-ref (types xcb-struct) field-tag)))
+ (vector-set! ((xcb-struct-accessor xcb-struct field-tag) rec) n
+ (make-typed-value
+ (with-bit-set
+ ((xcb-struct-vector-accessor xcb-struct field-tag) rec n)
+ (apply logior
+ (map
+ (lambda (arg)
+ (xcb-enum-get
+ (xcb-type-mask (hashq-ref (types xcb-struct) field-tag)) arg))
+ (if (list? arg) arg (list arg))))
+ t-or-f)
+ (hashq-ref (types xcb-struct) field-tag)))
+ (let ((val
+ (if (typed-value? arg)
+ (typecheck arg)
+ (let* ((xcb-type (hashq-ref (types xcb-struct) field-tag))
+ (resolve-val
+ (if (xcb-type-enum xcb-type)
+ (or (xcb-enum-get (xcb-type-enum xcb-type) arg)
+ (if (xcb-type-require-enum? xcb-type)
+ (error "xcb-xml: No enum value with name " arg)
+ arg))
+ arg)))
+ (typecheck (make-typed-value resolve-val xcb-type))))))
+ (vector-set! ((xcb-struct-accessor xcb-struct field-tag) rec) n val)))))
+
+(define (with-bit-set n bit val)
+ (if val (logior n bit) (logand n (lognot bit))))
(define (xcb-struct-modifier xcb-struct field-tag)
- (lambda (rec arg)
- (let ((val (if (typed-value? arg)
+ (lambda* (rec arg #:optional (t-or-f *unspecified*))
+ (if (and (not (eq? t-or-f *unspecified*))
+ (xcb-type-mask (hashq-ref (types xcb-struct) field-tag)))
+ ((record-modifier (underlying-record-type xcb-struct) field-tag) rec
+ (typecheck (make-typed-value
+ (with-bit-set
+ ((xcb-struct-accessor xcb-struct field-tag) rec)
+ (apply logior
+ (map
+ (lambda (arg)
+ (xcb-enum-get
+ (xcb-type-mask (hashq-ref (types xcb-struct) field-tag)) arg))
+ (if (list? arg) arg (list arg))))
+ t-or-f)
+ (hashq-ref (types xcb-struct) field-tag))))
+ (let ((val
+ (if (typed-value? arg)
(typecheck arg)
- (typecheck (make-typed-value arg (hashq-ref (types xcb-struct) field-tag))))))
- ((record-modifier (underlying-record-type xcb-struct) field-tag) rec val))))
+ (let* ((xcb-type (hashq-ref (types xcb-struct) field-tag))
+ (resolve-val
+ (if (xcb-type-enum xcb-type)
+ (or (xcb-enum-get (xcb-type-enum xcb-type) arg)
+ (if (xcb-type-require-enum? xcb-type)
+ (error "xcb-xml: No enum value with name " arg)
+ arg))
+ arg)))
+ (typecheck (make-typed-value resolve-val xcb-type))))))
+ ((record-modifier (underlying-record-type xcb-struct) field-tag) rec val)))))
(define (xcb-struct-pack xcb-struct rec port)
(let ((write-pad-bytes
@@ -226,11 +327,11 @@
(xcb-switch-pack (switch xcb-struct) xcb-struct rec port))))
(define (xcb-struct-unpack xcb-struct total-size port)
- (let* ((bytes-read 0)
+ (let* ((bytes-left (or total-size 0))
(skip-pad-bytes
(lambda (n)
(for-each (lambda (n) (get-u8 port)) (iota n))
- (set! bytes-read (+ bytes-read n))))
+ (set! bytes-left (- bytes-left n))))
(rec ((record-constructor (underlying-record-type xcb-struct) '()))))
(for-each
(lambda (field)
@@ -244,21 +345,22 @@
(size (if list-length-expression
(list-length-expression
(xcb-struct-field-ref-proc xcb-struct rec))
- (quotient (- total-size bytes-read) (xcb-type-size field-type))))
- (vec (make-vector size)))
- ((record-modifier (underlying-record-type xcb-struct) field-name) rec vec)
- (for-each
- (lambda (n)
- (vector-set!
- vec n
- (make-typed-value
- (typed-value-unpack field-type port)
- field-type)))
- (iota size))
- (set! bytes-read (+ bytes-read (* size (xcb-type-size field-type))))))
- ;; Events and replies from the X server don't contain
- ;; exprfields, but just in case you want to unpack a
- ;; request or struct you yourself packed before...
+ #f)))
+ ((record-modifier
+ (underlying-record-type xcb-struct) field-name) rec
+ (list->vector
+ (let read-next-list-item ((pre-vec-list '()) (size size))
+ (receive (unpack-size unpack-value)
+ (typed-value-unpack field-type port)
+ (set! bytes-left (- bytes-left unpack-size))
+ (if (or (and size (> size 1)) (and (not size) (> bytes-left )))
+ (list (read-next-list-item
+ (append pre-vec-list
+ (list (make-typed-value
+ unpack-value
+ field-type)))
+ (if size (- size 1) #f)))
+ (list (make-typed-value unpack-value field-type)))))))))
((*expr*)
((record-modifier (underlying-record-type xcb-struct) field-name)
rec
@@ -267,16 +369,18 @@
(xcb-struct-field-ref-proc xcb-struct rec))
field-type)))
(else
- ((record-modifier (underlying-record-type xcb-struct) field-name)
- rec
- (make-typed-value
- (typed-value-unpack field-type port)
- field-type)
- (set! bytes-read (+ bytes-read (xcb-type-size field-type)))))))))
- (field-order xcb-struct)
- (if (switch xcb-struct)
- (xcb-switch-unpack (switch xcb-struct) xcb-struct rec port)))
- rec))
+ (receive (unpack-size unpack-value)
+ (typed-value-unpack field-type port)
+ ((record-modifier (underlying-record-type xcb-struct) field-name)
+ rec
+ (make-typed-value
+ unpack-value
+ field-type))
+ (set! bytes-left (- bytes-left unpack-size))))))))
+ (field-order xcb-struct))
+ (if (switch xcb-struct)
+ (xcb-switch-unpack (switch xcb-struct) xcb-struct rec port))
+ (values (or total-size (- bytes-left)) rec)))
(define-record-type xcb-switch
(make-xcb-switch name expression case-expressions default)
@@ -286,6 +390,9 @@
(case-expressions xcb-switch-case-expressions)
(default xcb-switch-default))
+(define-public (make-empty-xcb-switch)
+ (make-xcb-switch #f (lambda (n) #f) '() #f))
+
(define-record-type xcb-case-expression
(make-xcb-case-expression name expression fields switches)
xcb-case-expression?
@@ -326,7 +433,8 @@
(if (every not (map xcb-case-expression-pack (xcb-switch-case-expressions switch)))
(typed-value-pack
(make-typed-value
- (((record-accessor (underlying-record-type xcb-struct) (car xcb-switch-default))) rec)
+ (((record-accessor (underlying-record-type xcb-struct)
+ (car (xcb-switch-default switch)))) rec)
(cdr xcb-switch-default))
port))))
@@ -355,10 +463,24 @@
(map xcb-switch-fields (xcb-case-expression-switches case-expression))))
(define (xcb-switch-fields switch)
- (let ((subfields
- (apply
- append
- (map xcb-case-expression-nested-fields (xcb-switch-case-expressions switch)))))
- (if (xcb-switch-default switch)
- (cons (xcb-switch-default switch) subfields)
- subfields)))
+ (if (not switch)
+ '()
+ (let ((subfields
+ (apply
+ append
+ (map xcb-case-expression-nested-fields (xcb-switch-case-expressions switch)))))
+ (if (xcb-switch-default switch)
+ (cons (xcb-switch-default switch) subfields)
+ subfields))))
+
+(define-public (xcb-struct-unpack-from-bytevector xcb-struct size bv)
+ (let ((port (open-bytevector-input-port bv)))
+ (xcb-struct-unpack xcb-struct size port)))
+
+(define-public (xcb-struct-pack-to-bytevector xcb-struct rec)
+ (call-with-values
+ (lambda ()
+ (open-bytevector-output-port))
+ (lambda (port get-bytevector)
+ (xcb-struct-pack xcb-struct rec port)
+ (get-bytevector))))
View
192 xcb/xml/test.scm
@@ -0,0 +1,192 @@
+(define-module (xcb xml test)
+ #:use-module (srfi srfi-64)
+ #:use-module (sxml simple)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (system base compile)
+ #:use-module (language xml-xcb spec)
+ #:use-module (language scheme spec)
+ #:use-module (xcb xml common)
+ #:use-module (xcb xml type)
+ #:use-module (xcb xml enum)
+ #:use-module (xcb xml struct))
+
+(define (test-reader string)
+ (xml->sxml string #:trim-whitespace? #t))
+
+(define (pack-xcb-struct-to-bytevector xcb-struct rec)
+ (call-with-values
+ (lambda ()
+ (open-bytevector-output-port))
+ (lambda (port get-bytevector)
+ (xcb-struct-pack xcb-struct rec port)
+ (get-bytevector))))
+
+(define test-xml "<xcb header=\"xproto\">
+ <!-- Core protocol types -->
+
+ <struct name=\"CHAR2B\">
+ <field type=\"CARD8\" name=\"byte1\" />
+ <field type=\"CARD8\" name=\"byte2\" />
+ </struct>
+
+ <struct name=\"FORMAT\">
+ <field type=\"CARD8\" name=\"depth\" />
+ <field type=\"CARD8\" name=\"bits_per_pixel\" />
+ <pad bytes=\"5\" />
+ <field type=\"CARD8\" name=\"scanline_pad\" />
+ </struct>
+
+ <typedef oldname=\"CARD32\" newname=\"VISUALID\" />
+
+ <enum name=\"VisualClass\">
+ <item name=\"StaticGray\"> <value>0</value></item>
+ <item name=\"GrayScale\"> <value>1</value></item>
+ <item name=\"StaticColor\"><value>2</value></item>
+ <item name=\"PseudoColor\"><value>3</value></item>
+ <item name=\"TrueColor\"> <value>4</value></item>
+ <item name=\"DirectColor\"><value>5</value></item>
+ </enum>
+
+ <struct name=\"VISUALTYPE\">
+ <field type=\"VISUALID\" name=\"visual_id\" />
+ <field type=\"CARD8\" name=\"class\" enum=\"VisualClass\" />
+ <field type=\"CARD8\" name=\"bits_per_rgb_value\" altenum=\"VisualClass\" />
+ <field type=\"CARD16\" name=\"colormap_entries\" />
+ <field type=\"CARD32\" name=\"red_mask\" />
+ <field type=\"CARD32\" name=\"green_mask\" />
+ <field type=\"CARD32\" name=\"blue_mask\" />
+ <pad bytes=\"4\" />
+ </struct>
+
+ <struct name=\"DEPTH\">
+ <field type=\"CARD8\" name=\"depth\" />
+ <pad bytes=\"1\" />
+ <field type=\"CARD16\" name=\"visuals_len\" />
+ <pad bytes=\"4\" />
+ <list type=\"VISUALTYPE\" name=\"visuals\">
+ <fieldref>visuals_len</fieldref>
+ </list>
+ </struct>
+
+ <enum name=\"BitEnum\">
+ <item name=\"One\"><bit>0</bit></item>
+ <item name=\"Two\"><bit>1</bit></item>
+ <item name=\"Four\"><bit>2</bit></item>
+ <item name=\"Eight\"><bit>3</bit></item>
+ <item name=\"Sixteen\"><bit>4</bit></item>
+ </enum>
+
+ <struct name=\"MASKSTRUCT\">
+ <field type=\"CARD8\" name=\"masked\" mask=\"BitEnum\" />
+ </struct>
+
+ <struct name=\"MASKLISTSTRUCT\">
+ <field type=\"CARD8\" name=\"mask_len\" />
+ <list type=\"CARD8\" mask=\"BitEnum\" name=\"mask_list\">
+ <fieldref>mask_len</fieldref>
+ </list>
+ </struct>
+
+ <struct name=\"ENUMLISTSTRUCT\">
+ <field type=\"CARD8\" name=\"enum_len\" />
+ <list type=\"CARD8\" enum=\"BitEnum\" name=\"enum_list\">
+ <fieldref>enum_len</fieldref>
+ </list>
+ <field type=\"CARD8\" name=\"altenum_len\" />
+ <list type=\"CARD8\" altenum=\"BitEnum\" name=\"altenum_list\">
+ <fieldref>altenum_len</fieldref>
+ </list>
+ </struct>
+
+</xcb>")
+
+(define-public (xml->scheme)
+ (pretty-print (compile (test-reader test-xml) #:from xml-xcb #:to scheme)))
+
+(test-begin "struct-test")
+(compile (test-reader test-xml) #:from xml-xcb #:env (current-module))
+(let ((my-char2b (make-CHAR2B 20 10)))
+ (test-eqv (CHAR2B-get-byte1 my-char2b) 20)
+ (test-eqv (CHAR2B-get-byte2 my-char2b) 10))
+
+(let* ((port (open-bytevector-input-port #vu8(10 20))))
+ (receive (size my-char2b)
+ (xcb-struct-unpack CHAR2B 2 port)
+ (test-eqv (CHAR2B-get-byte1 my-char2b) 10)
+ (test-eqv (CHAR2B-get-byte2 my-char2b) 20)))
+
+(let* ((port (open-bytevector-input-port #vu8(1 2 0 0 0 0 0 3))))
+ (receive (size my-format)
+ (xcb-struct-unpack FORMAT 8 port)
+ (test-eqv (FORMAT-get-depth my-format) 1)
+ (test-eqv (FORMAT-get-bits_per_pixel my-format) 2)
+ (test-eqv (FORMAT-get-scanline_pad my-format) 3)))
+
+(test-equal
+ (pack-xcb-struct-to-bytevector FORMAT (make-FORMAT 3 4 5))
+ #vu8(3 4 0 0 0 0 0 5))
+
+(typecheck (make-typed-value
+ (make-VISUALTYPE 3 'StaticColor 3 3 3 3 3)
+ VISUALTYPE-type))
+
+(let ((my-visualtype (make-VISUALTYPE 3 'StaticColor 3 3 3 3 3)))
+ (test-eqv (VISUALTYPE-get-bits_per_rgb_value my-visualtype) 3)
+ (VISUALTYPE-set-bits_per_rgb_value! my-visualtype 'StaticColor)
+ (test-eqv (VISUALTYPE-get-bits_per_rgb_value my-visualtype) 2)
+ (VISUALTYPE-set-bits_per_rgb_value! my-visualtype 8)
+ (test-eqv (VISUALTYPE-get-bits_per_rgb_value my-visualtype) 8))
+
+(let ((my-visualtype (make-VISUALTYPE 3 'StaticColor 'PseudoColor 3 3 3 3)))
+ (test-eqv (VISUALTYPE-get-bits_per_rgb_value my-visualtype) 3))
+
+(let ((my-depth (make-DEPTH 2 1)))
+ (DEPTH-set-visuals! my-depth 0 (make-VISUALTYPE 3 'PseudoColor 3 3 3 3 3))
+ (test-equal
+ (pack-xcb-struct-to-bytevector DEPTH my-depth)
+ #vu8(2 0 1 0 0 0 0 0 3 0 0 0 3 3 3 0 3 0 0 0 3 0 0 0 3 0 0 0 0 0 0 0)))
+
+(let* ((port
+ (open-bytevector-input-port #vu8(2 0 1 0 0 0 0 0
+ 3 0 0 0 3 3 3
+ 0 3 0 0 0 3 0
+ 0 0 3 0 0 0 0
+ 0 0 0))))
+ (receive (size my-depth)
+ (xcb-struct-unpack DEPTH 32 port)
+ (test-eqv size 32)
+ (test-eqv (DEPTH-get-depth my-depth) 2)
+ (let ((visual (DEPTH-get-visuals my-depth 0)))
+ (test-eqv (VISUALTYPE-get-green_mask visual) 3)
+ (test-eqv (VISUALTYPE-get-class visual) 3))))
+
+(let ((my-maskstruct (make-MASKSTRUCT 3)))
+ (test-eqv (MASKSTRUCT-get-masked my-maskstruct) 3)
+ (MASKSTRUCT-set-masked! my-maskstruct 5)
+ (test-eqv (MASKSTRUCT-get-masked my-maskstruct) 5)
+ (MASKSTRUCT-set-masked! my-maskstruct 'Eight #t)
+ (test-eqv (MASKSTRUCT-get-masked my-maskstruct) 13)
+ (MASKSTRUCT-set-masked! my-maskstruct '(Four Eight) #f)
+ (test-eqv (MASKSTRUCT-get-masked my-maskstruct) 1)
+ (MASKSTRUCT-set-masked! my-maskstruct '(Four Sixteen) #t)
+ (test-eqv (MASKSTRUCT-get-masked my-maskstruct) 21)
+ (test-error (MASKSTRUCT-set-masked! my-maskstruct '(Four Sixteen))))
+
+(let ((my-maskliststruct (make-MASKLISTSTRUCT 2)))
+ (MASKLISTSTRUCT-set-mask_list! my-maskliststruct 0 '(Four Eight) #t)
+ (test-eqv (MASKLISTSTRUCT-get-mask_list my-maskliststruct 0) 12)
+ (MASKLISTSTRUCT-set-mask_list! my-maskliststruct 0 'Eight #f)
+ (test-eqv (MASKLISTSTRUCT-get-mask_list my-maskliststruct 0) 4))
+
+(let ((my-enumliststruct (make-ENUMLISTSTRUCT 1 1)))
+ (ENUMLISTSTRUCT-set-altenum_list! my-enumliststruct 0 'Eight)
+ (test-eqv (ENUMLISTSTRUCT-get-altenum_list my-enumliststruct 0) 8)
+ (ENUMLISTSTRUCT-set-altenum_list! my-enumliststruct 0 64)
+ (test-eqv (ENUMLISTSTRUCT-get-altenum_list my-enumliststruct 0) 64)
+ (ENUMLISTSTRUCT-set-enum_list! my-enumliststruct 0 'Four)
+ (test-eqv (ENUMLISTSTRUCT-get-enum_list my-enumliststruct 0) 4)
+ (test-error (ENUMLISTSTRUCT-set-enum_list! my-enumliststruct 0 8)))
+
+(test-end "struct-test")
View
115 xcb/xml/type.scm
@@ -3,38 +3,51 @@
#:use-module (srfi srfi-1)
#:use-module (rnrs bytevectors)
#:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 receive)
#:use-module (srfi srfi-9 gnu)
+ #:use-module (xcb xml enum)
#:export (self-type
CARD8
CARD16
CARD32
+ INT16
typecheck
list-type
- type-predicate
typed-value-value
typed-value-type
make-xcb-type
typed-value?
typed-value-unpack
typed-value-pack
+ xcb-type?
+ xcb-type-name
xcb-type-list?
xcb-type-opaque?
+ xcb-type-mask
xcb-type-pack
xcb-type-size
+ xcb-type-enum
+ xcb-type-require-enum?
xcb-type-unpack
xcb-type-predicate
make-typed-value))
+(define-public (type-predicate predicate)
+ (lambda (val)
+ (predicate (typed-value-value val))))
+
(define-record-type xcb-type
- (make-xcb-type name predicate size pack unpack opaque?)
+ (make-xcb-type name predicate pack unpack opaque?)
xcb-type?
(name xcb-type-name)
(predicate xcb-type-predicate)
- (size xcb-type-size)
(pack xcb-type-pack)
(unpack xcb-type-unpack)
(opaque? xcb-type-opaque?)
- (list? xcb-type-list?))
+ (list? xcb-type-list?)
+ (mask xcb-type-mask)
+ (enum xcb-type-enum)
+ (require-enum? xcb-type-require-enum?))
(define (typed-value-pack value port)
((xcb-type-pack (typed-value-type value))
@@ -42,62 +55,75 @@
(typed-value-value value)))
(define (typed-value-unpack type port)
- ((xcb-type-unpack type)
- port))
+ (receive (size value)
+ ((xcb-type-unpack type)
+ port)
+ (values size value)))
(define (unsigned-bit-length-predicate bits)
(lambda (n)
(and (integer? n)
(>= n 0)
- (and (<= (integer-length n) bits)))))
+ (<= (integer-length n) bits))))
-(define-public (pack-uint-proc n)
+(define (signed-bit-length-predicate bits)
+ (lambda (n)
+ (and (integer? n)
+ (<= (integer-length n) (- bits 1)))))
+
+(define-public (pack-int-proc n)
(lambda (port value)
(let ((bv (make-bytevector n)))
(bytevector-uint-set! bv 0 value (native-endianness) n)
(put-bytevector port bv))))
-(define-public (unpack-uint-proc n)
+(define-public (unpack-int-proc n)
(lambda (port)
- (let ((bv (get-bytevector-n port n)))
- (bytevector-uint-ref bv 0 (native-endianness) n))))
+ (values
+ n
+ (let ((bv (get-bytevector-n port n)))
+ (bytevector-uint-ref bv 0 (native-endianness) n)))))
(define-public CARD8
(make-xcb-type
'CARD8
(type-predicate (unsigned-bit-length-predicate 8))
- 1
- (pack-uint-proc 1)
- (unpack-uint-proc 1)
+ (pack-int-proc 1)
+ (unpack-int-proc 1)
#f))
(define-public CARD16
(make-xcb-type
'CARD16
(type-predicate (unsigned-bit-length-predicate 16))
- 2
- (pack-uint-proc 2)
- (unpack-uint-proc 2)
+ (pack-int-proc 2)
+ (unpack-int-proc 2)
+ #f))
+
+(define-public INT16
+ (make-xcb-type
+ 'INT16
+ (type-predicate (signed-bit-length-predicate 16))
+ (pack-int-proc 2)
+ (unpack-int-proc 2)
#f))
(define-public CARD32
(make-xcb-type
'CARD32
(type-predicate (unsigned-bit-length-predicate 32))
- 4
- (pack-uint-proc 4)
- (unpack-uint-proc 4)
+ (pack-int-proc 4)
+ (unpack-int-proc 4)
#f))
(define-public BOOL
(make-xcb-type
'BOOL
(lambda (v) (or (eq? #t v) (eq? #f v)))
- 1
(lambda (port val)
(put-u8 port (if val 1 0)))
(lambda (port)
- (> (get-u8 port) 0))
+ (values 1 (> (get-u8 port) 0)))
#f))
(define-record-type typed-value
@@ -126,7 +152,6 @@
(make-xcb-type
name
(lambda (value) (eq? (typed-value-type value) type))
- 4
pack
unpack
opaque?)))
@@ -142,7 +167,6 @@
(make-xcb-type
name
(xcb-type-predicate to-clone)
- (xcb-type-size to-clone)
(xcb-type-pack to-clone)
(xcb-type-unpack to-clone)
(xcb-type-opaque? to-clone)))
@@ -152,7 +176,6 @@
name
(lambda (v)
(any (lambda (p) (p v)) (map xcb-type-predicate types)))
- (max (map xcb-type-size types))
pack
unpack
opaque?))
@@ -160,14 +183,48 @@
(define (list-type type)
((record-constructor
xcb-type
- '(name predicate pack unpack opaque? list?))
+ '(name predicate pack unpack opaque? list? enum require-enum? mask))
(xcb-type-name type)
(xcb-type-predicate type)
(xcb-type-pack type)
(xcb-type-unpack type)
(xcb-type-opaque? type)
- #t))
+ #t
+ (xcb-type-enum type)
+ (xcb-type-require-enum? type)
+ (xcb-type-mask type)))
-(define-public (type-predicate predicate)
+(define (predicate-and p1 p2)
(lambda (val)
- (predicate (typed-value-value val))))
+ (and (p1 val) (p2 val))))
+
+(define (xcb-enum-predicate enum)
+ (type-predicate
+ (lambda (val)
+ (if (xcb-enum-key-get enum val) #t
+ #f))))
+
+(define-public (enum-type type enum require-enum?)
+ ((record-constructor xcb-type '(name predicate pack unpack opaque? list? mask enum require-enum?))
+ (symbol-append (xcb-type-name type) (if require-enum? '-with-enum '-with-altenum))
+ (if require-enum?
+ (predicate-and (xcb-type-predicate type) (xcb-enum-predicate enum))
+ (xcb-type-predicate type))
+ (xcb-type-pack type)
+ (xcb-type-unpack type)
+ (xcb-type-opaque? type)
+ (xcb-type-list? type)
+ (xcb-type-mask type)
+ enum
+ require-enum?))
+
+(define-public (mask-type type enum)
+ ((record-constructor xcb-type '(name predicate pack unpack opaque? list? mask enum))
+ (symbol-append (xcb-type-name type) '-with-mask)
+ (xcb-type-predicate type)
+ (xcb-type-pack type)
+ (xcb-type-unpack type)
+ (xcb-type-opaque? type)
+ (xcb-type-list? type)
+ enum
+ #f))
Please sign in to comment.
Something went wrong with that request. Please try again.