feat: 9.5.9

nanopass/tests/unit-test-helpers-implementation.vicare.sls

@@ -0,0 +1,32 @@
+;;; Copyright (c) 2000-2015 Andrew W. Keep, R. Kent Dybvig
+;;; See the accompanying file Copyright for details
+
+(library (tests unit-test-helpers-implementation)
+  (export with-output-to-string display-condition format-error-message)
+  (import (vicare))
+
+  (define display-condition
+    (case-lambda
+      [(c) (display-condition c (current-output-port))]
+      [(c op)
+       (display
+         (format "~a~a~a~a~a"
+           (if (warning? c) "Warning" "Exception")
+           (if (who-condition? c) (format " in ~s" (condition-who c)) "")
+           (if (message-condition? c) (format ": ~a" (condition-message c)) "")
+           (if (and (irritants-condition? c) (not (null? (condition-irritants c))))
+               (format " with irritants ~s" (condition-irritants c))
+               "")
+           (if (syntax-violation? c)
+               (if (syntax-violation-subform c)
+                   (format "~s in ~s" (syntax-violation-subform c) (syntax-violation-form c))
+                   (format "~s" (syntax-violation-form c)))
+               ""))
+         op)]))
+
+  (define-syntax format-error-message
+    (syntax-rules ()
+      [(_ args ...) (format args ...)]))
+
+  ;; needed to get an r6rs script to print with vicare
+  (current-output-port (current-error-port)))