- Timestamp:
- 06/05/20 03:54:58 (8 months ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
release/5/apropos-srfi/trunk/tests/test-gloss.incl.scm
r38544 r38736 1 1 2 ;;; test "Gloss" API2 ;;; test "Gloss" API 3 3 4 (define-constant TEST-GLOSS-MARKER "--> ") 5 6 (define (test-group-ref group field . o) 7 (define (assq-ref ls key . o) 8 (cond 9 ((assq key ls) => cdr) 10 ((pair? o) (car o)) 11 (else #f) ) ) 12 (apply assq-ref (cdr group) field o) ) 4 ;; 13 5 14 6 (define test-indent-width) … … 17 9 (define test-indentation-char) 18 10 (let () 19 (import 20 (chicken syntax) 21 (only (chicken process-context) get-environment-variable)) 11 (import (chicken syntax)) 12 (import (only (chicken process-context) get-environment-variable)) 22 13 23 14 (define get-environment-variable/default … … 90 81 (checked-guard test-indentation-char char))) ) 91 82 83 ;; 84 85 ;from test? 86 (define (test-group-ref group field . o) 87 (define (assq-ref ls key . o) 88 (cond 89 ((assq key ls) => cdr) 90 ((pair? o) (car o)) 91 (else #f) ) ) 92 (apply assq-ref (cdr group) field o) ) 93 94 ;; 95 96 (define-constant TEST-GLOSS-MARKER "--> ") 97 92 98 (define (test-group-indent-string group) 93 99 (define (*test-group-level group) … … 99 105 (make-string (test-group-indent-width group) (test-indentation-char)) ) 100 106 107 (define (display-gloss-marker) 108 (display (test-group-indent-string (current-test-group))) 109 (display TEST-GLOSS-MARKER) ) 110 111 ;; 112 113 (define-syntax glossn 114 (syntax-rules () 115 ((glossn) 116 (begin)) 117 ((glossn ?obj) 118 (begin 119 (display-gloss-marker) 120 (display ?obj) 121 (flush-output)) ) 122 ((glossn ?obj ...) 123 (begin 124 (display-gloss-marker) 125 (for-each display (list ?obj ...)) 126 (flush-output)) ) ) ) 127 101 128 (define-syntax gloss 102 129 (syntax-rules () 103 130 ((gloss) 104 (newline) 131 (newline)) 105 132 ((gloss ?obj ...) 106 133 (begin 107 (display (test-group-indent-string (current-test-group))) 108 (display TEST-GLOSS-MARKER) 109 (for-each display (list ?obj ...)) 134 (glossn ?obj ...) 110 135 (newline)) ) ) ) 111 136 137 ;Needs a format: 112 138 ;(import (only (chicken format) format)) ;builtin 113 139 ;(import format) ;egg 140 141 (define-syntax glossnf 142 (syntax-rules () 143 ((glossnf ?fmt ?arg0 ...) 144 (glossn (format #f ?fmt ?arg0 ...)) ) ) ) 145 114 146 (define-syntax glossf 115 147 (syntax-rules () 116 148 ((glossf ?fmt ?arg0 ...) 117 (gloss (format #f ?fmt ?arg0 ...)) ) ) ) 149 (begin 150 (glossnf ?fmt ?arg0 ...) 151 (newline)) ) ) )
Note: See TracChangeset
for help on using the changeset viewer.