>From bb282a6e0da59d1e53db123be89a511b0b22e8bd Mon Sep 17 00:00:00 2001
From: Christian Kellermann <address@hidden>
Date: Sun, 26 May 2013 14:41:01 +0200
Subject: [PATCH] Add specialisation for make-promise, retain procedures as
 they are

---
 chicken.import.scm   | 1 +
 library.scm          | 5 ++---
 tests/r7rs-tests.scm | 2 +-
 tests/runtests.sh    | 4 ++++
 types.db             | 3 +++
 5 files changed, 11 insertions(+), 4 deletions(-)

diff --git a/chicken.import.scm b/chicken.import.scm
index b394bf7..9e06b6e 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 6c4e8a9..7fecadc 100644
--- a/library.scm
+++ b/library.scm
@@ -4741,9 +4741,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 dce6bb2..c0fdac9 100644
--- a/tests/r7rs-tests.scm
+++ b/tests/r7rs-tests.scm
@@ -43,7 +43,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)))
 
 (report-errs)
diff --git a/tests/runtests.sh b/tests/runtests.sh
index 931e2f2..4fdd7fc 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 01d84e2..f0ae40b 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))))
-- 
1.8.1.2