[functional tests] Remove dependency on the ThunderChez library.

I've just moved the relevant code into the functional-tests dir.
2020-04-30 12:07:42 +01:00
parent ad79b627a4
commit 3e5de399a7
61 changed files with 16836 additions and 16 deletions
--- a/functional-tests/fmt/fmt-color.scm
+++ b/functional-tests/fmt/fmt-color.scm
@@ -0,0 +1,77 @@
+;;;; fmt-color.scm -- colored output
+;;
+;; Copyright (c) 2006-2007 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define (fmt-color st) (fmt-ref st 'color))
+(define (fmt-in-html? st) (fmt-ref st 'in-html?))
+(define (fmt-use-html-font? st) (fmt-ref st 'use-html-font?))
+
+(define (color->ansi x)
+  (if (number? x)
+      (let ((r (arithmetic-shift x -16))
+            (g (bitwise-and (arithmetic-shift x -8) #xFF))
+            (b (bitwise-and x #xFF)))
+        ;; just picks the highest color value - need to detect blends
+        (color->ansi
+         (cond
+           ((> r g) (if (> r b) 'red 'blue))
+           ((> g b) 'green)
+           (else 'blue))))
+      (case x
+        ((bold) "1")
+        ((dark) "2")
+        ((underline) "4")
+        ((black) "30")
+        ((red) "31")
+        ((green) "32")
+        ((yellow) "33")
+        ((blue) "34")
+        ((magenta) "35")
+        ((cyan) "36")
+        ((white) "37")
+        (else "0"))))
+
+(define (ansi-escape color)
+  (cat (integer->char 27) "[" (color->ansi color) "m"))
+
+(define (fmt-in-html . args)
+  (fmt-let 'in-html? #t (apply-cat args)))
+
+(define (fmt-colored color . args)
+  (fmt-if fmt-in-html?
+          (cond
+            ((eq? color 'bold)
+             (cat "<b>" (apply-cat args) "</b>"))
+            ((eq? color 'underline)
+             (cat "<u>" (apply-cat args) "</u>"))
+            (else
+             (let ((cname (if (number? color) (cat "#" color) color)))
+               (fmt-if fmt-use-html-font?
+                       (cat "<font color=\"" cname "\">" (apply-cat args)
+                            "</font>")
+                       (cat "<span style=color:\"" cname "\">"
+                            (apply-cat args) "</span>")))))
+          (lambda (st)
+            (let ((old-color (fmt-color st)))
+              ((fmt-let 'color color
+                        (cat (ansi-escape color)
+                             (apply-cat args)
+                             (if (or (memv color '(bold underline))
+                                     (memv old-color '(bold underline)))
+                                 (ansi-escape 'reset)
+                                 (lambda (st) st))
+                             (ansi-escape old-color)))
+               st)))))
+
+(define (fmt-red . args) (fmt-colored 'red (apply-cat args)))
+(define (fmt-blue . args) (fmt-colored 'blue (apply-cat args)))
+(define (fmt-green . args) (fmt-colored 'green (apply-cat args)))
+(define (fmt-cyan . args) (fmt-colored 'cyan (apply-cat args)))
+(define (fmt-yellow . args) (fmt-colored 'yellow (apply-cat args)))
+(define (fmt-magenta . args) (fmt-colored 'magenta (apply-cat args)))
+(define (fmt-white . args) (fmt-colored 'white (apply-cat args)))
+(define (fmt-black . args) (fmt-colored 'black (apply-cat args)))
+(define (fmt-bold . args) (fmt-colored 'bold (apply-cat args)))
+(define (fmt-underline . args) (fmt-colored 'underline (apply-cat args)))
+