diff options
Diffstat (limited to 'module/srfi')
| -rw-r--r-- | module/srfi/srfi-41/util.scm | 38 | ||||
| -rw-r--r-- | module/srfi/srfi-64/test-error.scm | 85 |
2 files changed, 86 insertions, 37 deletions
diff --git a/module/srfi/srfi-41/util.scm b/module/srfi/srfi-41/util.scm index 7c062003..9a172e2d 100644 --- a/module/srfi/srfi-41/util.scm +++ b/module/srfi/srfi-41/util.scm @@ -3,7 +3,7 @@ #:use-module (srfi srfi-41) #:use-module ((ice-9 sandbox) :select (call-with-time-limit)) #:use-module (hnh util) ; let*, find-min - #:export (stream-car+cdr interleave-streams with-streams + #:export (stream-car+cdr interleave-streams stream-timeslice-limit)) (define (stream-car+cdr stream) @@ -132,39 +132,3 @@ (stream-timeslice-limit (stream-cdr strm) timeslice))) (lambda _ stream-null))) -;; Evaluates @var{body} in a context where most list fundamentals are -;; replaced by stream alternatives. -;; commented defifinitions are items which could be included, but for -;; one reason or another isn't. -;; TODO Possibly give access to list-primitives under a list- prefix. -;; TODO since this macro is inhygienic it requires that (srfi srfi-41) -;; is included at the point of use. -(define-macro (with-streams . body) - `(let-syntax - ((cons (identifier-syntax stream-cons)) - (null? (identifier-syntax stream-null?)) - (pair? (identifier-syntax stream-pair?)) - (car (identifier-syntax stream-car)) - (cdr (identifier-syntax stream-cdr)) - ;; stream-lambda - ;; define-stream - (append (identifier-syntax stream-append)) - (concat (identifier-syntax stream-concat)) - ;; (const stream-constant) - (drop (identifier-syntax stream-drop)) - (drop-while (identifier-syntax stream-drop-while)) - (filter (identifier-syntax stream-filter)) - (fold (identifier-syntax stream-fold)) - (for-each (identifier-syntax stream-for-each)) - (length (identifier-syntax stream-length)) - ;; stream-let - (map (identifier-syntax stream-map)) - ;; stream-match - ;; stream-range - ;; stream-ref - (reverse (identifier-syntax stream-reverse)) - ;; stream-scan - (take (identifier-syntax stream-take)) - (take-while (identifier-syntax stream-take-while)) - (zip (identifier-syntax stream-zip))) - ,@body)) diff --git a/module/srfi/srfi-64/test-error.scm b/module/srfi/srfi-64/test-error.scm new file mode 100644 index 00000000..33922c32 --- /dev/null +++ b/module/srfi/srfi-64/test-error.scm @@ -0,0 +1,85 @@ +;; Copyright © 2022 Hugo Hörnquist +;; Copyright for this file, however, majority of contents borrowed under the +;; below mentioned license agreement from srfi/srfi-64/testing.scm of Guile 2.2.7. + +;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner +;; Added "full" support for Chicken, Gauche, Guile and SISC. +;; Alex Shinn, Copyright (c) 2005. +;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012. +;; Support for Guile 2 by Mark H Weaver <mhw@netris.org>, Copyright (c) 2014. +;; +;; 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. +;;; Commentary: +;; The code is directly copied from Guile's source tree +;; (module/srfi/srfi-64/testing.scm), but @var{etype} +;; is passed to @code{catch}, causing it to actually +;; check the expected error. +;;; Code: + +(define-module (srfi srfi-64 test-error) + :use-module (srfi srfi-64) + :use-module (hnh util) + :replace (test-error)) + +(define %test-source-line2 (@@ (srfi srfi-64) %test-source-line2)) +(define %test-on-test-begin (@@ (srfi srfi-64) %test-on-test-begin)) +(define %test-on-test-end (@@ (srfi srfi-64) %test-on-test-end)) +(define %test-report-result (@@ (srfi srfi-64) %test-report-result)) + +(define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (cond ((%test-on-test-begin r) + (let ((et etype)) + (test-result-set! r 'expected-error et) + (%test-on-test-end r + (catch etype + (lambda () + (test-result-set! r 'actual-value expr) + #f) + (lambda (key . args) + ;; TODO: decide how to specify expected + ;; error types for Guile. + (test-result-set! r 'actual-error + (cons key args)) + #t))) + (%test-report-result))))))) + +(define-syntax test-error + (lambda (x) + (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () + (((mac tname etype expr) line) + (syntax + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (cons (cons 'test-name tname) line)) + (%test-error r etype expr)))) + (((mac etype expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-error r etype expr)))) + (((mac expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-error r #t expr))))))) + |