* Peter Bex <peter....@xs4all.nl> [130526 14:10]:
> On Sun, May 26, 2013 at 01:55:48PM +0200, Christian Kellermann wrote:
> > Hi,
> >
> > the first step of implementing the lazy procedures from R7RS is
> > attached to this mail. I will probably have to adjust the internal
> > representation for recursive promisses again but I am not yet sure
> > about how to do this best.
> >
> > This patch also adds a new R7RS test file that will host all new
> > test cases that would not find a nice place elsewhere.
>
> Thanks, I've pushed this so that we can start hacking on other R7 stuff
> and add it to this place.
>
> The make-promise itself looks good.
Unfortunately not so good, please find a correction attached. Also
this adds proper type information, takes care of the optimisation
in the compiler when possible, and adds the "test suite" to make
check.
Also make-promise is now exported in the chicken egg. I am not sure
whether we should place it there but it seems more convenient than
to provide a r7rs-core thing you need to import as well...
Thanks for bearing with me,
Christian
--
In the world, there is nothing more submissive and weak than
water. Yet for attacking that which is hard and strong, nothing can
surpass it. --- Lao Tzu
>From bb282a6e0da59d1e53db123be89a511b0b22e8bd Mon Sep 17 00:00:00 2001
From: Christian Kellermann <ck...@pestilenz.org>
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
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
