commit 5d93773aa354b3bed6652575a81ebc6cd0c99f9b
parent 324776cf38b0ff856208a2edb78849f5fe53aaff
Author: Andres Navarro <canavarro82@gmail.com>
Date: Fri, 2 Dec 2011 00:03:51 -0300
Added $delay to the ground environment.
Diffstat:
9 files changed, 68 insertions(+), 21 deletions(-)
diff --git a/TODO b/TODO
@@ -18,33 +18,28 @@
typedef like lua)
* fix:
** fix char-ready? and u8-ready? (r7rs)
-** fix some inconsistencies between the man page and the interpreter
- behaviour (especially in the displaying of the message).
* documentation
** update the manual with the current features
** add a section to the manual with the interpreter usage
-* operatives:
-** $delay (r7rs)
-** $case (r7rs)
-** $case-lambda (r7rs)
-** $case-vau (r7rs)
-** $named-let (r7rs)
-** $do (r7rs)
-** $define-record-type (r7rs)
* applicatives:
+** optional argument to member? (r7rs)
+** optional argument to assoc (r7rs)
** number->string (r7rs)
** string->number (r7rs)
* reader/writer
** syntax support for complex numbers (Kernel report)
-* other
-** optional argument to member? (r7rs)
-** optional argument to assoc (r7rs)
+* library
** some simplified error guarding (r7rs)
+** $case (r7rs)
+** $case-lambda + $case-vau (r7rs)
+** $named-let + $do (r7rs)
+** $define-record-type (r7rs)
+** eager comprehensions (at least for check.k) see SRFIs 42 and 78
+ (srfi)
+* other
** restarts (r7rs/common lisp)
** add restart support to the repl/interpreter (r7rs)
** simple modules (something inspired in r7rs) (r7rs)
** add modules support to the interpreter (r7rs)
-** eager comprehensions (at least for check.k) see SRFIs 42 and 78
- (srfi)
** complex numbers (Kernel report)
** interval arithmetic (Kernel report)
diff --git a/src/Makefile b/src/Makefile
@@ -190,7 +190,7 @@ kghelpers.o: kghelpers.c kghelpers.h kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kerror.h kpair.h kgc.h kapplicative.h \
koperative.h kcontinuation.h kenvironment.h ksymbol.h kstring.h ktable.h \
kinteger.h imath.h krational.h imrat.h kbytevector.h kvector.h \
- kencapsulation.h
+ kencapsulation.h kpromise.h
kgkd_vars.o: kgkd_vars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kcontinuation.h koperative.h \
kapplicative.h kenvironment.h kerror.h kghelpers.h ksymbol.h kstring.h \
diff --git a/src/kgc.c b/src/kgc.c
@@ -604,6 +604,7 @@ static void markroot (klisp_State *K) {
/* NOTE: next_x_params is protected by next_obj */
markvalue(K, K->eval_op);
markvalue(K, K->list_app);
+ markvalue(K, K->memoize_app);
markvalue(K, K->ground_env);
markvalue(K, K->module_params_sym);
markvalue(K, K->root_cont);
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -25,6 +25,7 @@
#include "kpair.h"
#include "kcontinuation.h"
#include "kencapsulation.h"
+#include "kpromise.h"
/* Initialization of continuation names */
void kinit_kghelpers_cont_names(klisp_State *K)
@@ -730,6 +731,21 @@ int64_t klcm32_64(int32_t a_, int32_t b_)
return (a / gcd) * b;
}
+/* This is needed in kstate & promises */
+void memoize(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ UNUSED(xparams);
+ UNUSED(denv);
+
+ bind_1p(K, ptree, exp);
+ TValue new_prom = kmake_promise(K, exp, KNIL);
+ kapply_cc(K, new_prom);
+}
+
/* list applicative (used in kstate and kgpairs_lists) */
void list(klisp_State *K)
{
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -450,6 +450,8 @@ int64_t klcm32_64(int32_t a, int32_t b);
** Other
*/
+/* memoize applicative (used in kstate & promises) */
+void memoize(klisp_State *K);
/* list applicative (used in kstate and kgpairs_lists) */
void list(klisp_State *K);
diff --git a/src/kgpromises.c b/src/kgpromises.c
@@ -111,7 +111,10 @@ void Slazy(klisp_State *K)
}
/* 9.1.4 memoize */
-void memoize(klisp_State *K)
+/* in kghelpers.c */
+
+/* $delay it's actually a short hand for ($lazy (memoize ...)) */
+void Sdelay(klisp_State *K)
{
TValue *xparams = K->next_xparams;
TValue ptree = K->next_value;
@@ -121,7 +124,11 @@ void memoize(klisp_State *K)
UNUSED(denv);
bind_1p(K, ptree, exp);
- TValue new_prom = kmake_promise(K, exp, KNIL);
+ TValue promise_body = kcons(K, exp, KNIL);
+ krooted_vars_push(K, &promise_body);
+ promise_body = kcons(K, K->memoize_app, promise_body);
+ TValue new_prom = kmake_promise(K, promise_body, denv);
+ krooted_vars_pop(K);
kapply_cc(K, new_prom);
}
@@ -140,6 +147,8 @@ void kinit_promises_ground_env(klisp_State *K)
add_operative(K, ground_env, "$lazy", Slazy, 0);
/* 9.1.4 memoize */
add_applicative(K, ground_env, "memoize", memoize, 0);
+ /* 9.1.5? $delay */
+ add_applicative(K, ground_env, "$delay", Sdelay, 0);
}
/* init continuation names */
diff --git a/src/kstate.c b/src/kstate.c
@@ -37,7 +37,7 @@
#include "kbytevector.h"
#include "kvector.h"
-#include "kghelpers.h" /* for creating list_app */
+#include "kghelpers.h" /* for creating list_app & memoize_app */
#include "kgerrors.h" /* for creating error hierarchy */
#include "kgc.h" /* for memory freeing & gc init */
@@ -214,20 +214,30 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
int32_t line_number;
TValue si;
K->eval_op = kmake_operative(K, keval_ofn, 0), line_number = __LINE__;
+#if KTRACK_SI
si = kcons(K, kstring_new_b_imm(K, __FILE__),
kcons(K, i2tv(line_number), i2tv(0)));
kset_source_info(K, K->eval_op, si);
-
+#endif
/* TODO: si */
TValue eval_name = ksymbol_new_b(K, "eval", KNIL);
ktry_set_name(K, K->eval_op, eval_name);
K->list_app = kmake_applicative(K, list, 0), line_number = __LINE__;
+#if KTRACK_SI
si = kcons(K, kstring_new_b_imm(K, __FILE__),
kcons(K, i2tv(__LINE__), i2tv(0)));
kset_source_info(K, K->list_app, si);
kset_source_info(K, kunwrap(K->list_app), si);
+#endif
+ K->memoize_app = kmake_applicative(K, memoize, 0), line_number = __LINE__;
+#if KTRACK_SI
+ si = kcons(K, kstring_new_b_imm(K, __FILE__),
+ kcons(K, i2tv(__LINE__), i2tv(0)));
+ kset_source_info(K, K->memoize_app, si);
+ kset_source_info(K, kunwrap(K->memoize_app), si);
+#endif
/* ground environment has a hashtable for bindings */
K->ground_env = kmake_table_environment(K, KNIL);
// K->ground_env = kmake_empty_environment(K);
diff --git a/src/kstate.h b/src/kstate.h
@@ -74,6 +74,7 @@ struct klisp_State {
TValue eval_op; /* the operative for evaluation */
TValue list_app; /* the applicative for list evaluation */
+ TValue memoize_app; /* the applicative for promise memoize */
TValue ground_env; /* the environment with all the ground definitions */
/* standard environments are environments with no bindings and ground_env
as parent */
diff --git a/src/tests/promises.k b/src/tests/promises.k
@@ -25,9 +25,10 @@
($check-error ($lazy))
($check-error ($lazy "too" "many"))
+($check equal? (force ($lazy (get-current-environment)))
+ (get-current-environment))
;; Test cases from R(-1)RK
-
($define! lazy-test-1
($sequence
($provide! (get-count p)
@@ -104,3 +105,15 @@
($check equal? (force (force (memoize ($lazy 0)))) 0)
($check equal? (force ($lazy (memoize 0))) 0)
($check equal? (force (force ($lazy (memoize 0)))) 0)
+
+;; 9.1.5? $delay
+
+($check-error (memoize))
+($check-error (memoize "too" "many"))
+
+($check equal? (force ($delay 0)) 0)
+($check equal? (force (force ($delay 0))) 0)
+($check equal? (force ($delay (get-current-environment)))
+ (get-current-environment))
+($check-predicate (promise? (force ($delay (memoize 0)))))
+($check equal? (force (force ($delay (memoize 0)))) 0)
