diff options
| -rw-r--r-- | srfi/srfi-64.scm | 4 | ||||
| -rw-r--r-- | srfi/srfi-64.upstream.scm | 198 |
2 files changed, 132 insertions, 70 deletions
diff --git a/srfi/srfi-64.scm b/srfi/srfi-64.scm index 03a1c0c1d5..f053443b39 100644 --- a/srfi/srfi-64.scm +++ b/srfi/srfi-64.scm @@ -4,7 +4,7 @@ test-approximate test-assert test-error test-apply test-with-runner test-match-nth test-match-all test-match-any test-match-name test-skip test-expect-fail test-read-eval-string - test-runner-group-path test-group-with-cleanup + test-runner-group-path test-group test-group-with-cleanup test-result-ref test-result-set! test-result-clear test-result-remove test-result-kind test-passed? test-log-to-file @@ -35,5 +35,7 @@ test-on-final-simple test-on-test-end-simple test-on-final-simple)) +(cond-expand-provide (current-module) '(srfi-64)) + ;; Load Per Bothner's original SRFI-64 implementation. (load-from-path "srfi/srfi-64.upstream.scm") diff --git a/srfi/srfi-64.upstream.scm b/srfi/srfi-64.upstream.scm index 45a7af3785..d686662bfd 100644 --- a/srfi/srfi-64.upstream.scm +++ b/srfi/srfi-64.upstream.scm @@ -1,4 +1,8 @@ -;; Copyright (c) 2005, 2006 Per Bothner +;; 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 @@ -23,8 +27,14 @@ (cond-expand (chicken (require-extension syntax-case)) - (guile + (guile-2 (use-modules (srfi srfi-9) + ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated + ;; with either Guile's native exceptions or R6RS exceptions. + ;;(srfi srfi-34) (srfi srfi-35) + (srfi srfi-39))) + (guile + (use-modules (ice-9 syncase) (srfi srfi-9) ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7 (srfi srfi-39))) (sisc @@ -57,7 +67,7 @@ test-approximate test-assert test-error test-apply test-with-runner test-match-nth test-match-all test-match-any test-match-name test-skip test-expect-fail test-read-eval-string - test-runner-group-path test-group-with-cleanup + test-runner-group-path test-group test-group-with-cleanup test-result-ref test-result-set! test-result-clear test-result-remove test-result-kind test-passed? test-log-to-file @@ -108,7 +118,7 @@ (> (vector-length obj) 1) (eq (vector-ref obj 0) %test-runner-cookie))) (define (alloc) - (let ((runner (make-vector 22))) + (let ((runner (make-vector 23))) (vector-set! runner 0 %test-runner-cookie) runner)) (begin @@ -156,19 +166,20 @@ ) (define (test-runner-reset runner) - (test-runner-pass-count! runner 0) - (test-runner-fail-count! runner 0) - (test-runner-xpass-count! runner 0) - (test-runner-xfail-count! runner 0) - (test-runner-skip-count! runner 0) - (%test-runner-total-count! runner 0) - (%test-runner-count-list! runner '()) - (%test-runner-run-list! runner #t) - (%test-runner-skip-list! runner '()) - (%test-runner-fail-list! runner '()) - (%test-runner-skip-save! runner '()) - (%test-runner-fail-save! runner '()) - (test-runner-group-stack! runner '())) + (test-result-alist! runner '()) + (test-runner-pass-count! runner 0) + (test-runner-fail-count! runner 0) + (test-runner-xpass-count! runner 0) + (test-runner-xfail-count! runner 0) + (test-runner-skip-count! runner 0) + (%test-runner-total-count! runner 0) + (%test-runner-count-list! runner '()) + (%test-runner-run-list! runner #t) + (%test-runner-skip-list! runner '()) + (%test-runner-fail-list! runner '()) + (%test-runner-skip-save! runner '()) + (%test-runner-fail-save! runner '()) + (test-runner-group-stack! runner '())) (define (test-runner-group-path runner) (reverse (test-runner-group-stack runner))) @@ -232,7 +243,7 @@ (else #t))) r)) -(define (%test-specificier-matches spec runner) +(define (%test-specifier-matches spec runner) (spec runner)) (define (test-runner-create) @@ -243,7 +254,7 @@ (let loop ((l list)) (cond ((null? l) result) (else - (if (%test-specificier-matches (car l) runner) + (if (%test-specifier-matches (car l) runner) (set! result #t)) (loop (cdr l))))))) @@ -311,12 +322,6 @@ (log-file (cond-expand (mzscheme (open-output-file log-file-name 'truncate/replace)) - (guile-2 - (with-fluids ((%default-port-encoding - "UTF-8")) - (let ((p (open-output-file log-file-name))) - (setvbuf p _IOLBF) - p))) (else (open-output-file log-file-name))))) (display "%%%% Starting test " log-file) (display suite-name log-file) @@ -469,7 +474,7 @@ (if test-name (%test-write-result1 test-name log)) (if source-file (%test-write-result1 source-file log)) (if source-line (%test-write-result1 source-line log)) - (if source-file (%test-write-result1 source-form log)))))) + (if source-form (%test-write-result1 source-form log)))))) (define-syntax test-result-ref (syntax-rules () @@ -570,9 +575,10 @@ ((%test-evaluate-with-catch test-expression) (catch #t (lambda () test-expression) - (lambda (key . args) #f) (lambda (key . args) - (display-backtrace (make-stack #t) (current-error-port)))))))) + (test-result-set! (test-runner-current) 'actual-error + (cons key args)) + #f)))))) (kawa (define-syntax %test-evaluate-with-catch (syntax-rules () @@ -609,12 +615,27 @@ (kawa (define (%test-syntax-file form) (syntax-source form)))) - (define-for-syntax (%test-source-line2 form) + (define (%test-source-line2 form) (let* ((line (syntax-line form)) (file (%test-syntax-file form)) (line-pair (if line (list (cons 'source-line line)) '()))) (cons (cons 'source-form (syntax-object->datum form)) (if file (cons (cons 'source-file file) line-pair) line-pair))))) + (guile-2 + (define (%test-source-line2 form) + (let* ((src-props (syntax-source form)) + (file (and src-props (assq-ref src-props 'filename))) + (line (and src-props (assq-ref src-props 'line))) + (file-alist (if file + `((source-file . ,file)) + '())) + (line-alist (if line + `((source-line . ,(+ line 1))) + '()))) + (datum->syntax (syntax here) + `((source-form . ,(syntax->datum form)) + ,@file-alist + ,@line-alist))))) (else (define (%test-source-line2 form) '()))) @@ -645,10 +666,16 @@ (%test-on-test-end r (comp exp res))))) (%test-report-result))))) -(define (%test-approximimate= error) +(define (%test-approximate= error) (lambda (value expected) - (and (>= value (- expected error)) - (<= value (+ expected error))))) + (let ((rval (real-part value)) + (ival (imag-part value)) + (rexp (real-part expected)) + (iexp (imag-part expected))) + (and (>= rval (- rexp error)) + (>= ival (- iexp error)) + (<= rval (+ rexp error)) + (<= ival (+ iexp error)))))) (define-syntax %test-comp1body (syntax-rules () @@ -662,12 +689,12 @@ (%test-report-result))))) (cond-expand - ((or kawa mzscheme) + ((or kawa mzscheme guile-2) ;; Should be made to work for any Scheme with syntax-case ;; However, I haven't gotten the quoting working. FIXME. (define-syntax test-end (lambda (x) - (syntax-case (list x (list 'quote (%test-source-line2 x))) () + (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () (((mac suite-name) line) (syntax (%test-end suite-name line))) @@ -676,7 +703,7 @@ (%test-end #f line)))))) (define-syntax test-assert (lambda (x) - (syntax-case (list x (list 'quote (%test-source-line2 x))) () + (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () (((mac tname expr) line) (syntax (let* ((r (test-runner-get)) @@ -688,8 +715,8 @@ (let* ((r (test-runner-get))) (test-result-alist! r line) (%test-comp1body r expr))))))) - (define-for-syntax (%test-comp2 comp x) - (syntax-case (list x (list 'quote (%test-source-line2 x)) comp) () + (define (%test-comp2 comp x) + (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) () (((mac tname expected expr) line comp) (syntax (let* ((r (test-runner-get)) @@ -709,18 +736,18 @@ (lambda (x) (%test-comp2 (syntax equal?) x))) (define-syntax test-approximate ;; FIXME - needed for non-Kawa (lambda (x) - (syntax-case (list x (list 'quote (%test-source-line2 x))) () + (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () (((mac tname expected expr error) line) (syntax (let* ((r (test-runner-get)) (name tname)) (test-result-alist! r (cons (cons 'test-name tname) line)) - (%test-comp2body r (%test-approximimate= error) expected expr)))) + (%test-comp2body r (%test-approximate= error) expected expr)))) (((mac expected expr error) line) (syntax (let* ((r (test-runner-get))) (test-result-alist! r line) - (%test-comp2body r (%test-approximimate= error) expected expr)))))))) + (%test-comp2body r (%test-approximate= error) expected expr)))))))) (else (define-syntax test-end (syntax-rules () @@ -765,16 +792,30 @@ (define-syntax test-approximate (syntax-rules () ((test-approximate tname expected expr error) - (%test-comp2 (%test-approximimate= error) tname expected expr)) + (%test-comp2 (%test-approximate= error) tname expected expr)) ((test-approximate expected expr error) - (%test-comp2 (%test-approximimate= error) expected expr)))))) + (%test-comp2 (%test-approximate= error) expected expr)))))) (cond-expand (guile (define-syntax %test-error (syntax-rules () ((%test-error r etype expr) - (%test-comp1body r (catch #t (lambda () expr) (lambda (key . args) #t))))))) + (cond ((%test-on-test-begin r) + (let ((et etype)) + (test-result-set! r 'expected-error et) + (%test-on-test-end r + (catch #t + (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)))))))) (mzscheme (define-syntax %test-error (syntax-rules () @@ -791,23 +832,34 @@ (kawa (define-syntax %test-error (syntax-rules () + ((%test-error r #t expr) + (cond ((%test-on-test-begin r) + (test-result-set! r 'expected-error #t) + (%test-on-test-end r + (try-catch + (let () + (test-result-set! r 'actual-value expr) + #f) + (ex <java.lang.Throwable> + (test-result-set! r 'actual-error ex) + #t))) + (%test-report-result)))) ((%test-error r etype expr) - (let () - (if (%test-on-test-begin r) - (let ((et etype)) - (test-result-set! r 'expected-error et) - (%test-on-test-end r - (try-catch - (let () - (test-result-set! r 'actual-value expr) - #f) - (ex <java.lang.Throwable> - (test-result-set! r 'actual-error ex) - (cond ((and (instance? et <gnu.bytecode.ClassType>) - (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>)) - (instance? ex et)) - (else #t))))) - (%test-report-result)))))))) + (if (%test-on-test-begin r) + (let ((et etype)) + (test-result-set! r 'expected-error et) + (%test-on-test-end r + (try-catch + (let () + (test-result-set! r 'actual-value expr) + #f) + (ex <java.lang.Throwable> + (test-result-set! r 'actual-error ex) + (cond ((and (instance? et <gnu.bytecode.ClassType>) + (gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>)) + (instance? ex et)) + (else #t))))) + (%test-report-result))))))) ((and srfi-34 srfi-35) (define-syntax %test-error (syntax-rules () @@ -816,15 +868,15 @@ (and (condition? ex) (condition-has-type? ex etype))) ((procedure? etype) (etype ex)) - ((equal? type #t) + ((equal? etype #t) #t) (else #t)) - expr)))))) + expr #f)))))) (srfi-34 (define-syntax %test-error (syntax-rules () ((%test-error r etype expr) - (%test-comp1body r (guard (ex (else #t)) expr)))))) + (%test-comp1body r (guard (ex (else #t)) expr #f)))))) (else (define-syntax %test-error (syntax-rules () @@ -835,11 +887,11 @@ (%test-report-result))))))) (cond-expand - ((or kawa mzscheme) + ((or kawa mzscheme guile-2) (define-syntax test-error (lambda (x) - (syntax-case (list x (list 'quote (%test-source-line2 x))) () + (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () (((mac tname etype expr) line) (syntax (let* ((r (test-runner-get)) @@ -860,11 +912,17 @@ (define-syntax test-error (syntax-rules () ((test-error name etype expr) - (test-assert name (%test-error etype expr))) + (let ((r (test-runner-get))) + (test-result-alist! r `((test-name . ,name))) + (%test-error r etype expr))) ((test-error etype expr) - (test-assert (%test-error etype expr))) + (let ((r (test-runner-get))) + (test-result-alist! r '()) + (%test-error r etype expr))) ((test-error expr) - (test-assert (%test-error #t expr))))))) + (let ((r (test-runner-get))) + (test-result-alist! r '()) + (%test-error r #t expr))))))) (define (test-apply first . rest) (if (test-runner? first) @@ -873,7 +931,7 @@ (if r (let ((run-list (%test-runner-run-list r))) (cond ((null? rest) - (%test-runner-run-list! r (reverse! run-list)) + (%test-runner-run-list! r (reverse run-list)) (first)) ;; actually apply procedure thunk (else (%test-runner-run-list! @@ -973,7 +1031,9 @@ (let* ((port (open-input-string string)) (form (read port))) (if (eof-object? (read-char port)) - (eval form) + (cond-expand + (guile (eval form (current-module))) + (else (eval form))) (cond-expand (srfi-23 (error "(not at eof)")) (else "error"))))) |