Author: yamakenz
Date: Wed Jul 18 03:15:02 2007
New Revision: 4740
Added:
sigscheme-trunk/test/test-promise.scm
Modified:
sigscheme-trunk/NEWS
sigscheme-trunk/QALog
sigscheme-trunk/configure.in
sigscheme-trunk/doc/spec.txt
sigscheme-trunk/src/promise.c
sigscheme-trunk/src/sigscheme.c
sigscheme-trunk/src/sigschemeinternal.h
sigscheme-trunk/test/bigloo-letrec.scm
sigscheme-trunk/test/test-r4rs.scm
Log:
* src/sigschemeinternal.h
- (scm_init_promise): New function decl
* src/promise.c
- Include functable-r5rs-promise.c
- (PROMISE_FORCEDP): New macro
- (l_tag_unforced): New static variable
- (scm_init_promise): New function
- (scm_s_delay, scm_p_force): Implement
* src/sigscheme.c
- (scm_initialize_internal): Add scm_init_promise()
- Move functable-r5rs-promise.c inclusion to promise.c
* test/test-promise.scm
- New file
- Add R5RS examples as tests
* test/test-r4rs.scm
- Enable test-delay
* test/bigloo-letrec.scm
- Disable implementation-dependent test for R5RS promises
* configure.in
- Enable promise by default
- Enable promise by default for conf=uim
* doc/spec.txt
* QALog
* NEWS
- Update
Modified: sigscheme-trunk/NEWS
==============================================================================
--- sigscheme-trunk/NEWS (original)
+++ sigscheme-trunk/NEWS Wed Jul 18 03:15:02 2007
@@ -3,6 +3,8 @@
* New features
+ - R5RS promises (delay and force)
+
- SRFI-1 List Library
- SRFI-55 require-extension
Modified: sigscheme-trunk/QALog
==============================================================================
--- sigscheme-trunk/QALog (original)
+++ sigscheme-trunk/QALog Wed Jul 18 03:15:02 2007
@@ -264,7 +264,7 @@
yyyy yyy r5rs vector.c
yyyy yyy r5rs qquote.c
r5rs macro.c
- r5rs promise.c
+yyyy yy r5rs promise.c
yyyy yyy srfi module-srfi1.c
yyyy yyy srfi module-srfi2.c
yyyy yyy srfi module-srfi6.c
@@ -905,13 +905,13 @@
file: promise.c
category: r5rs
-spec by eyes:
-spec by tests:
-general review:
-64-bit by eyes:
+spec by eyes: [EMAIL PROTECTED]
+spec by tests: [EMAIL PROTECTED]
+general review: [EMAIL PROTECTED]
+64-bit by eyes: [EMAIL PROTECTED]
64-bit by tests:
-coding style:
-normal case tests:
+coding style: [EMAIL PROTECTED]
+normal case tests: [EMAIL PROTECTED]
corner case tests:
file: module-srfi1.c
@@ -1097,6 +1097,9 @@
* gcroots.h
* gcroots.c
- QA done again @r4734
+
+ * promise.c
+ - QA done @r4740
2007-07-13 YamaKen <yamaken AT bp.iij4u.or.jp>
* module-srfi55.c
Modified: sigscheme-trunk/configure.in
==============================================================================
--- sigscheme-trunk/configure.in (original)
+++ sigscheme-trunk/configure.in Wed Jul 18 03:15:02 2007
@@ -463,7 +463,7 @@
use_continuation=yes
use_quasiquote=yes
use_hygienic_macro=no
- use_promise=no
+ use_promise=yes
use_int=yes
use_numeric_io=yes
use_char=yes
@@ -631,7 +631,7 @@
AX_FEATURE_ARG_Y(continuation, [R5RS continuation])
AX_FEATURE_ARG_Y(quasiquote, [R5RS quasiquotation])
AX_FEATURE_ARG_N(hygienic-macro, [R5RS hygienic macros (experimental)])
-AX_FEATURE_ARG_N(promise, [R5RS promise (not implemented yet)])
+AX_FEATURE_ARG_Y(promise, [R5RS promise])
AX_FEATURE_VAR_N(number, [R5RS numbers])
AX_FEATURE_ARG_Y(int, [R5RS integer numbers])
AX_FEATURE_VAR_N(rational, [R5RS rational numbers (not implemented yet)])
Modified: sigscheme-trunk/doc/spec.txt
==============================================================================
--- sigscheme-trunk/doc/spec.txt (original)
+++ sigscheme-trunk/doc/spec.txt Wed Jul 18 03:15:02 2007
@@ -367,6 +367,16 @@
7
================================================================
+Promises
+~~~~~~~~
+
+SigScheme only supports explicit forcing. And passing non-promise objects to
+force is an error.
+
+----------------------------------------------------------------
+ (+ (delay (* 3 7)) 13) ==> error
+----------------------------------------------------------------
+
Syntaxes/procedures not implemented
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -408,12 +418,6 @@
- *procedure:* angle z
- *procedure:* exact->inexact z
- *procedure:* inexact->exact z
-
-Promises
-^^^^^^^^
-
- - *library syntax:* delay <expression>
- - *library procedure:* force promise
System interface
^^^^^^^^^^^^^^^^
Modified: sigscheme-trunk/src/promise.c
==============================================================================
--- sigscheme-trunk/src/promise.c (original)
+++ sigscheme-trunk/src/promise.c Wed Jul 18 03:15:02 2007
@@ -41,6 +41,7 @@
/*=======================================
File Local Macro Definitions
=======================================*/
+#define PROMISE_FORCEDP(p) (!EQ(CAR(p), l_tag_unforced))
/*=======================================
File Local Type Definitions
@@ -49,6 +50,15 @@
/*=======================================
Variable Definitions
=======================================*/
+#include "functable-r5rs-promise.c"
+
+SCM_GLOBAL_VARS_BEGIN(static_promise);
+#define static
+static ScmObj l_tag_unforced;
+#undef static
+SCM_GLOBAL_VARS_END(static_promise);
+#define l_tag_unforced SCM_GLOBAL_VAR(static_promise, l_tag_unforced)
+SCM_DEFINE_STATIC_VARS(static_promise);
/*=======================================
File Local Function Declarations
@@ -57,15 +67,32 @@
/*=======================================
Function Definitions
=======================================*/
+SCM_EXPORT void
+scm_init_promise(void)
+{
+ SCM_GLOBAL_VARS_INIT(static_promise);
+
+ scm_register_funcs(scm_functable_r5rs_promise);
+
+ /* Use a pair as the unique tag. The symbol %%unforced-promise is only for
+ * human-readability. */
+ scm_gc_protect_with_init(&l_tag_unforced,
+ LIST_1(scm_intern("%%unforced-promise")));
+}
+
/*===========================================================================
R5RS : 4.2 Derived expression types : 4.2.5 Delayed evaluation
===========================================================================*/
SCM_EXPORT ScmObj
scm_s_delay(ScmObj exp, ScmObj env)
{
+ ScmObj proc;
DECLARE_FUNCTION("delay", syntax_fixed_1);
- ERR("not implemented yet");
+ proc = scm_s_lambda(SCM_NULL, LIST_1(exp), env);
+
+ /* (result . proc) */
+ return CONS(l_tag_unforced, proc);
}
/*===========================================================================
@@ -74,7 +101,25 @@
SCM_EXPORT ScmObj
scm_p_force(ScmObj promise)
{
+ ScmObj proc, result;
DECLARE_FUNCTION("force", procedure_fixed_1);
- ERR("not implemented yet");
+ ENSURE_CONS(promise);
+
+ proc = CDR(promise);
+ ENSURE_PROCEDURE(proc);
+
+ if (PROMISE_FORCEDP(promise))
+ return CAR(promise);
+
+ /* R5RS:
+ * Rationale: A promise may refer to its own value, as in the last
+ * example above. Forcing such a promise may cause the promise to be
+ * forced a second time before the value of the first force has been
+ * computed. This complicates the definition of `make-promise'. */
+ result = scm_call(proc, SCM_NULL);
+ if (PROMISE_FORCEDP(promise))
+ return CAR(promise);
+ SET_CAR(promise, result);
+ return result;
}
Modified: sigscheme-trunk/src/sigscheme.c
==============================================================================
--- sigscheme-trunk/src/sigscheme.c (original)
+++ sigscheme-trunk/src/sigscheme.c Wed Jul 18 03:15:02 2007
@@ -77,9 +77,6 @@
#if SCM_USE_QUASIQUOTE
#include "functable-r5rs-qquote.c"
#endif
-#if SCM_USE_PROMISE
-#include "functable-r5rs-promise.c"
-#endif
#if SCM_USE_NUMBER
#include "functable-r5rs-number.c"
#endif
@@ -287,7 +284,7 @@
scm_init_macro();
#endif
#if SCM_USE_PROMISE
- scm_register_funcs(scm_functable_r5rs_promise);
+ scm_init_promise();
#endif
/* R5RS Procedures */
Modified: sigscheme-trunk/src/sigschemeinternal.h
==============================================================================
--- sigscheme-trunk/src/sigschemeinternal.h (original)
+++ sigscheme-trunk/src/sigschemeinternal.h Wed Jul 18 03:15:02 2007
@@ -738,6 +738,9 @@
/* error.c */
SCM_EXPORT void scm_init_error(void);
+/* promise.c */
+SCM_EXPORT void scm_init_promise(void);
+
/* procedure.c */
SCM_EXPORT ScmObj scm_map_single_arg(ScmObj proc, ScmObj lst);
SCM_EXPORT ScmObj scm_map_multiple_args(ScmObj proc, ScmObj lsts,
Modified: sigscheme-trunk/test/bigloo-letrec.scm
==============================================================================
--- sigscheme-trunk/test/bigloo-letrec.scm (original)
+++ sigscheme-trunk/test/bigloo-letrec.scm Wed Jul 18 03:15:02 2007
@@ -81,7 +81,9 @@
(define (test-letrec)
(test "letrec" ((test1 1) "TOTO") 'TOTO1)
(test "letrec" (foo 10) 'done)
- (test "delay" (procedure? (letrec ((foo (delay foo))) (force foo))) #t))
+ ;; implementation-dependent test -- YamaKen 2007-07-18
+ ;;(test "delay" (procedure? (letrec ((foo (delay foo))) (force foo))) #t)
+ )
(test-letrec)
Added: sigscheme-trunk/test/test-promise.scm
==============================================================================
--- (empty file)
+++ sigscheme-trunk/test/test-promise.scm Wed Jul 18 03:15:02 2007
@@ -0,0 +1,66 @@
+;; Filename : test-promise.scm
+;; About : unit tests for R5RS promise
+;;
+;; Copyright (c) 2007 SigScheme Project <uim-en AT googlegroups.com>
+;;
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions
+;; are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright
+;; notice, this list of conditions and the following disclaimer.
+;; 2. Redistributions in binary form must reproduce the above copyright
+;; notice, this list of conditions and the following disclaimer in the
+;; documentation and/or other materials provided with the distribution.
+;; 3. Neither the name of authors nor the names of its contributors
+;; may be used to endorse or promote products derived from this software
+;; without specific prior written permission.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
+;; IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
+;; THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
+;; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
+;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
+;; PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
+;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
+;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
+;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(load "test/unittest.scm")
+
+(if (not (symbol-bound? 'force))
+ (test-skip "R5RS promise is not enabled"))
+
+(define tn test-name)
+
+(tn "promise R5RS examples")
+(assert-equal? (tn) 3 (force (delay (+ 1 2))))
+(assert-equal? (tn) '(3 3) (let ((p (delay (+ 1 2))))
+ (list (force p) (force p))))
+(define a-stream
+ (letrec ((next
+ (lambda (n)
+ (cons n (delay (next (+ n 1)))))))
+ (next 0)))
+(define head car)
+(define tail
+ (lambda (stream) (force (cdr stream))))
+(assert-equal? (tn) 2 (head (tail (tail a-stream))))
+
+(define count 0)
+(define p
+ (delay (begin (set! count (+ count 1))
+ (if (> count x)
+ count
+ (force p)))))
+(define x 5)
+(assert-equal? (tn) 6 (force p))
+(assert-equal? (tn) 6 (begin (set! x 10)
+ (force p)))
+
+
+(total-report)
Modified: sigscheme-trunk/test/test-r4rs.scm
==============================================================================
--- sigscheme-trunk/test/test-r4rs.scm (original)
+++ sigscheme-trunk/test/test-r4rs.scm Wed Jul 18 03:15:02 2007
@@ -1270,6 +1270,7 @@
(newline)
(display "(test-cont) (test-sc4) (test-delay)")
(newline)
+(test-delay)
"last item in file"
(total-report)
