Changeset 38736 in project for release

Timestamp:

06/05/20 03:54:58 (8 months ago)

Author:

Kon Lovett

Message:

add test gloss

File:

• release/5/apropos-srfi/trunk/tests/test-gloss.incl.scm (modified) (4 diffs)

release/5/apropos-srfi/trunk/tests/test-gloss.incl.scm

@@ -1 +1 @@
 
-;;;test "Gloss" API
+;;; test "Gloss" API
 
-(define-constant TEST-GLOSS-MARKER "--> ")
-
-(define (test-group-ref group field . o)
-  (define (assq-ref ls key . o)
-    (cond
-      ((assq key ls)    => cdr)
-      ((pair? o)        (car o))
-      (else             #f) ) )
-  (apply assq-ref (cdr group) field o) )
+;;
 
 (define test-indent-width)
@@ -17 +9 @@
 (define test-indentation-char)
 (let ()
-  (import
-    (chicken syntax)
-    (only (chicken process-context) get-environment-variable))
+  (import (chicken syntax))
+  (import (only (chicken process-context) get-environment-variable))
 
   (define get-environment-variable/default
@@ -90 +81 @@
       (checked-guard test-indentation-char char))) )
 
+;;
+
+;from test?
+(define (test-group-ref group field . o)
+  (define (assq-ref ls key . o)
+    (cond
+      ((assq key ls)    => cdr)
+      ((pair? o)        (car o))
+      (else             #f) ) )
+  (apply assq-ref (cdr group) field o) )
+
+;;
+
+(define-constant TEST-GLOSS-MARKER "--> ")
+
 (define (test-group-indent-string group)
   (define (*test-group-level group)
@@ -99 +105 @@
   (make-string (test-group-indent-width group) (test-indentation-char)) )
 
+(define (display-gloss-marker)
+  (display (test-group-indent-string (current-test-group)))
+  (display TEST-GLOSS-MARKER) )
+
+;;
+
+(define-syntax glossn
+  (syntax-rules ()
+    ((glossn)
+      (begin))
+    ((glossn ?obj)
+      (begin
+        (display-gloss-marker)
+        (display ?obj)
+        (flush-output)) )
+    ((glossn ?obj ...)
+      (begin
+        (display-gloss-marker)
+        (for-each display (list ?obj ...))
+        (flush-output)) ) ) )
+
 (define-syntax gloss
   (syntax-rules ()
     ((gloss)
-      (newline) )
+      (newline))
     ((gloss ?obj ...)
       (begin
-        (display (test-group-indent-string (current-test-group)))
-        (display TEST-GLOSS-MARKER)
-        (for-each display (list ?obj ...))
+        (glossn ?obj ...)
         (newline)) ) ) )
 
+;Needs a format:
 ;(import (only (chicken format) format)) ;builtin
 ;(import format)                         ;egg
+
+(define-syntax glossnf
+  (syntax-rules ()
+    ((glossnf ?fmt ?arg0 ...)
+      (glossn (format #f ?fmt ?arg0 ...)) ) ) )
+
 (define-syntax glossf
   (syntax-rules ()
     ((glossf ?fmt ?arg0 ...)
-      (gloss (format #f ?fmt ?arg0 ...)) ) ) )
+      (begin
+        (glossnf ?fmt ?arg0 ...)
+        (newline)) ) ) )