~ chicken-core (chicken-5) 4dca8212ee08050d45639e96a1510a2081e03a8b

commit 4dca8212ee08050d45639e96a1510a2081e03a8b
Author:     Christian Kellermann <ckeen@pestilenz.org>
AuthorDate: Sun May 26 14:41:01 2013 +0200
Commit:     Peter Bex <peter.bex@xs4all.nl>
CommitDate: Sun May 26 17:01:29 2013 +0200

    Add specialisation for make-promise, retain procedures as they are
    
    Signed-off-by: Peter Bex <peter.bex@xs4all.nl>

diff --git a/chicken.import.scm b/chicken.import.scm
index b394bf73..9e06b6e8 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -170,6 +170,7 @@
    make-blob
    make-composite-condition
    make-parameter
+   make-promise
    make-property-condition
    maximum-flonum
    memory-statistics
diff --git a/library.scm b/library.scm
index 9bea2b45..f42ddd7f 100644
--- a/library.scm
+++ b/library.scm
@@ -4745,9 +4745,8 @@ EOF
   (##sys#structure? x 'promise) )
 
 (define (make-promise obj)
-  (cond ((promise? obj) obj)
-        ((procedure? obj) (##sys#make-promise obj))
-        (else (##sys#make-promise (lambda () obj)))))
+  (if (promise? obj) obj
+      (##sys#make-promise (lambda () obj))))
 
 ;;; Internal string-reader:
 
diff --git a/tests/r7rs-tests.scm b/tests/r7rs-tests.scm
index c322a349..bba67291 100644
--- a/tests/r7rs-tests.scm
+++ b/tests/r7rs-tests.scm
@@ -65,7 +65,7 @@
 (test #t promise? (make-promise (make-promise 1)))
 
 (test 1 force (make-promise 1))
-(test 1 force (make-promise (lambda _ 1)))
+(test #t procedure? (force (make-promise (lambda _ 1))))
 (test 1 force (make-promise (make-promise 1)))
 
 
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 931e2f23..4fdd7fca 100755
--- a/tests/runtests.sh
+++ b/tests/runtests.sh
@@ -260,6 +260,10 @@ echo "======================================== syntax tests (r5rs_pitfalls) ..."
 echo "(expect two failures)"
 $interpret -i -s r5rs_pitfalls.scm
 
+echo "======================================== r7rs tests ..."
+$interpret -i -s r7rs-tests.scm
+
+
 echo "======================================== module tests ..."
 $interpret -include-path .. -s module-tests.scm
 $interpret -include-path .. -s module-tests-2.scm
diff --git a/types.db b/types.db
index 5510a367..05d54d13 100644
--- a/types.db
+++ b/types.db
@@ -1014,6 +1014,9 @@
 (program-name (#(procedure #:clean #:enforce) program-name (#!optional string) string))
 (promise? (#(procedure #:pure #:predicate (struct promise)) promise? (*) boolean))
 
+(make-promise (#(procedure #:enforce) make-promise (*) (struct promise))
+              (((struct promise)) #(1)))
+
 (put! (#(procedure #:clean #:enforce) put! (symbol symbol *) undefined)
       ((symbol symbol *)
        (##core#inline_allocate ("C_a_i_putprop" 8) #(1) #(2) #(3))))