>From 8ea6b67fef2484e85404e537f3a3c0d939a8fc59 Mon Sep 17 00:00:00 2001 From: Christian Kellermann Date: Sun, 26 May 2013 13:37:26 +0200 Subject: [PATCH] Add make-promise from R7RS to core This also introduces tests/r7rs-tests: A place for the R7RS tests that don't belong anywhere else. --- library.scm | 4 ++++ tests/r7rs-tests.scm | 49 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 53 insertions(+) create mode 100644 tests/r7rs-tests.scm diff --git a/library.scm b/library.scm index 5a2862e..6c4e8a9 100644 --- a/library.scm +++ b/library.scm @@ -4740,6 +4740,10 @@ EOF (define (promise? x) (##sys#structure? x 'promise) ) +(define (make-promise obj) + (cond ((promise? obj) obj) + ((procedure? obj) (##sys#make-promise obj)) + (else (##sys#make-promise (lambda () obj))))) ;;; Internal string-reader: diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm new file mode 100644 index 0000000..dce6bb2 --- /dev/null +++ b/tests/r7rs-tests.scm @@ -0,0 +1,49 @@ +;; R7RS Tests + +;; Copied from R4RS tests +(define cur-section '())(define errs '()) +(define SECTION (lambda args + (display "SECTION") (write args) (newline) + (set! cur-section args) #t)) +(define record-error (lambda (e) (set! errs (cons (list cur-section e) errs)))) + +(define test + (lambda (expect fun . args) + (write (cons fun args)) + (display " ==> ") + ((lambda (res) + (write res) + (newline) + (cond ((not (equal? expect res)) + (record-error (list res expect (cons fun args))) + (display " BUT EXPECTED ") + (write expect) + (newline) + #f) + (else #t))) + (if (procedure? fun) (apply fun args) (car args))))) +(define (report-errs) + (newline) + (if (null? errs) (display "Passed all tests") + (begin + (display "errors were:") + (newline) + (display "(SECTION (got expected (call)))") + (newline) + (for-each (lambda (l) (write l) (newline)) + errs))) + (newline)) + +(SECTION 4 2 5) + + +;; make-promise test +(test #t promise? (make-promise 1)) +(test #t promise? (make-promise (lambda _ 'foo))) +(test #t promise? (make-promise (make-promise 1))) + +(test 1 force (make-promise 1)) +(test 1 force (make-promise (lambda _ 1))) +(test 1 force (make-promise (make-promise 1))) + +(report-errs) -- 1.8.1.2