~ chicken-core (chicken-5) 02bc6447c00d0b56248688bc4e9ae6c6bb2aa8ec

commit 02bc6447c00d0b56248688bc4e9ae6c6bb2aa8ec
Author:     Christian Kellermann <ckeen@necronomicon.my.domain>
AuthorDate: Sun May 26 13:37:26 2013 +0200
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sun May 26 14:04:24 2013 +0200

    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.
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/library.scm b/library.scm
index 5a2862e4..6c4e8a9b 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 00000000..dce6bb29
--- /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)