commit 5fed3daf3f2f77ee14577ea8ec6d05a2900dda16
parent 21cd8de4d55864ec3a380dfa1a8a85c459dcb154
Author: Andres Navarro <canavarro82@gmail.com>
Date: Mon, 28 Nov 2011 02:40:19 -0300
Refactor: cleaned all the kg*.h files. Moved all shared functionality to kghelpers. Eliminated the now useless name parameter in a lot of internal functions (like check_list). Regression: temporarily disabled the continuation names.
Diffstat:
51 files changed, 1739 insertions(+), 2426 deletions(-)
diff --git a/TODO b/TODO
@@ -43,9 +43,6 @@
** read-line (r7rs)
** number->string (r7rs)
** string->number (r7rs)
-** char-digit?
-** digit->char
-** char->digit
* reader
** symbol escapes (r7rs)
** string escapes (r7rs)
diff --git a/src/Makefile b/src/Makefile
@@ -119,9 +119,9 @@ kauxlib.o: kauxlib.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
ktoken.h kmem.h
kbytevector.o: kbytevector.c kbytevector.h kobject.h klimits.h klisp.h \
klispconf.h kstate.h ktoken.h kmem.h kgc.h kstring.h
+kchar.o: kchar.c kobject.h klimits.h klisp.h klispconf.h
kcontinuation.o: kcontinuation.c kcontinuation.h kobject.h klimits.h \
klisp.h klispconf.h kstate.h ktoken.h kmem.h kgc.h
-kchar.o: kchar.c kchar.h kobject.h klimits.h klisp.h klispconf.h kstate.h
kencapsulation.o: kencapsulation.c kobject.h klimits.h klisp.h \
klispconf.h kmem.h kstate.h ktoken.h kencapsulation.h kpair.h kgc.h
kenvironment.o: kenvironment.c kenvironment.h kobject.h klimits.h klisp.h \
@@ -134,47 +134,48 @@ keval.o: keval.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
kgbooleans.o: kgbooleans.c kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kpair.h kgc.h ksymbol.h kstring.h \
kcontinuation.h kerror.h kghelpers.h kapplicative.h koperative.h \
- kenvironment.h
+ kenvironment.h kgbooleans.h
kgbytevectors.o: kgbytevectors.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h \
kerror.h kpair.h kgc.h kbytevector.h kghelpers.h kenvironment.h \
- ksymbol.h kstring.h kgbytevectors.h kgnumbers.h
+ ksymbol.h kstring.h kgbytevectors.h
kgc.o: kgc.c kgc.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kport.h imath.h imrat.h ktable.h kstring.h kbytevector.h \
kvector.h kerror.h kpair.h
+kgchars.o: kgchars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
+ ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
+ kpair.h kgc.h kchar.h kghelpers.h kenvironment.h ksymbol.h kstring.h \
+ kgchars.h
kgcombiners.o: kgcombiners.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h \
ksymbol.h kstring.h koperative.h kapplicative.h kerror.h kghelpers.h \
- kgpair_mut.h kgenv_mut.h kgcontrol.h kgcombiners.h
+ kgcombiners.h
kgcontinuations.o: kgcontinuations.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h \
kapplicative.h koperative.h ksymbol.h kstring.h kerror.h kghelpers.h \
- kgcontinuations.h kgcontrol.h
+ kgcontinuations.h
kgcontrol.o: kgcontrol.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kcontinuation.h kerror.h kghelpers.h \
kapplicative.h koperative.h kenvironment.h ksymbol.h kstring.h \
- kgcontrol.h kgcombiners.h
+ kgcontrol.h
kgencapsulations.o: kgencapsulations.c kstate.h klimits.h klisp.h \
kobject.h klispconf.h ktoken.h kmem.h kencapsulation.h kapplicative.h \
koperative.h kerror.h kpair.h kgc.h kghelpers.h kcontinuation.h \
kenvironment.h ksymbol.h kstring.h kgencapsulations.h
+kgenv_mut.o: kgenv_mut.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
+ ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h ksymbol.h \
+ kstring.h kerror.h kghelpers.h kapplicative.h koperative.h kgenv_mut.h
kgenvironments.o: kgenvironments.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h \
ksymbol.h kstring.h kerror.h kghelpers.h kapplicative.h koperative.h \
- kgenvironments.h kgenv_mut.h kgpair_mut.h kgcontrol.h
-kgenv_mut.o: kgenv_mut.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kpair.h kgc.h kenvironment.h kcontinuation.h ksymbol.h \
- kstring.h kerror.h kghelpers.h kapplicative.h koperative.h kgenv_mut.h \
- kgcontrol.h
+ kgenvironments.h
kgeqp.o: kgeqp.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kpair.h kgc.h kcontinuation.h kerror.h kghelpers.h \
- kapplicative.h koperative.h kenvironment.h ksymbol.h kstring.h kgeqp.h \
- kinteger.h imath.h krational.h imrat.h
+ kapplicative.h koperative.h kenvironment.h ksymbol.h kstring.h kgeqp.h
kgequalp.o: kgequalp.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kpair.h kvector.h kgc.h kstring.h kbytevector.h \
+ ktoken.h kmem.h kpair.h kgc.h kvector.h kstring.h kbytevector.h \
kcontinuation.h kerror.h kghelpers.h kapplicative.h koperative.h \
- kenvironment.h ksymbol.h kgeqp.h kinteger.h imath.h krational.h imrat.h \
- kgequalp.h
+ kenvironment.h ksymbol.h kgequalp.h
kgerrors.o: kgerrors.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kstring.h kpair.h kgc.h kerror.h kghelpers.h \
kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \
@@ -182,20 +183,16 @@ kgerrors.o: kgerrors.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kgffi.o: kgffi.c imath.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kinteger.h kpair.h kgc.h kerror.h kbytevector.h \
kencapsulation.h ktable.h kghelpers.h kapplicative.h koperative.h \
- kcontinuation.h kenvironment.h ksymbol.h kstring.h kgencapsulations.h \
- kgcombiners.h kgcontinuations.h kgffi.h
+ kcontinuation.h kenvironment.h ksymbol.h kstring.h kgffi.h
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 kinteger.h \
- imath.h
-kgchars.o: kgchars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
- kpair.h kgc.h kchar.h kghelpers.h kenvironment.h ksymbol.h kstring.h \
- kgchars.h
+ koperative.h kcontinuation.h kenvironment.h ksymbol.h kstring.h \
+ kinteger.h imath.h krational.h imrat.h kbytevector.h kvector.h \
+ kencapsulation.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 \
- kgcontinuations.h kgkd_vars.h
+ kgkd_vars.h
kgks_vars.o: kgks_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 \
@@ -203,21 +200,19 @@ kgks_vars.o: kgks_vars.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
kgnumbers.o: kgnumbers.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
kpair.h kgc.h ksymbol.h kstring.h kinteger.h imath.h krational.h imrat.h \
- kreal.h kghelpers.h kenvironment.h kgnumbers.h kgkd_vars.h
+ kreal.h kghelpers.h kenvironment.h kgnumbers.h
kgpair_mut.o: kgpair_mut.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kcontinuation.h ksymbol.h \
kstring.h kerror.h kghelpers.h kapplicative.h koperative.h \
- kenvironment.h kgpair_mut.h kgeqp.h kinteger.h imath.h krational.h \
- imrat.h kgnumbers.h
+ kenvironment.h kgpair_mut.h
kgpairs_lists.o: kgpairs_lists.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpair.h kgc.h kstring.h kcontinuation.h \
kenvironment.h ksymbol.h kerror.h kghelpers.h kapplicative.h \
- koperative.h kgequalp.h kgpairs_lists.h kgnumbers.h imath.h
+ koperative.h kgpairs_lists.h
kgports.o: kgports.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kport.h kstring.h kbytevector.h kenvironment.h \
kapplicative.h koperative.h kcontinuation.h kpair.h kgc.h kerror.h \
- ksymbol.h kread.h kwrite.h kghelpers.h kgports.h \
- kgcontinuations.h kgcontrol.h kgkd_vars.h
+ ksymbol.h kread.h kwrite.h kghelpers.h kgports.h
kgpromises.o: kgpromises.c kstate.h klimits.h klisp.h kobject.h \
klispconf.h ktoken.h kmem.h kpromise.h kpair.h kgc.h kapplicative.h \
koperative.h kcontinuation.h kerror.h kghelpers.h kenvironment.h \
@@ -225,35 +220,34 @@ kgpromises.o: kgpromises.c kstate.h klimits.h klisp.h kobject.h \
kground.o: kground.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kground.h kghelpers.h kerror.h kpair.h kgc.h \
kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \
- kstring.h kgbooleans.h kgeqp.h kinteger.h imath.h krational.h imrat.h \
- kgequalp.h kgsymbols.h kgcontrol.h kgpairs_lists.h kgpair_mut.h \
- kgenvironments.h kgenv_mut.h kgcombiners.h kgcontinuations.h \
- kgencapsulations.h kgpromises.h kgkd_vars.h kgks_vars.h kgnumbers.h \
- kgstrings.h kgchars.h kgports.h kgbytevectors.h kgvectors.h kgsystem.h \
- kgerrors.h kgffi.h ktable.h keval.h krepl.h
+ kstring.h kgbooleans.h kgeqp.h kgequalp.h kgsymbols.h kgcontrol.h \
+ kgpairs_lists.h kgpair_mut.h kgenvironments.h kgenv_mut.h kgcombiners.h \
+ kgcontinuations.h kgencapsulations.h kgpromises.h kgkd_vars.h \
+ kgks_vars.h kgnumbers.h kgstrings.h kgchars.h kgports.h kgbytevectors.h \
+ kgvectors.h kgsystem.h kgerrors.h $(if $(USE_LIBFFI),kgffi.h) ktable.h \
+ keval.h krepl.h
kgstrings.o: kgstrings.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
- kpair.h kgc.h ksymbol.h kstring.h kghelpers.h kenvironment.h kvector.h \
- kbytevector.h kgstrings.h kgnumbers.h
+ kpair.h kgc.h ksymbol.h kstring.h kchar.h kvector.h kbytevector.h \
+ kghelpers.h kenvironment.h kgstrings.h
kgsymbols.o: kgsymbols.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kcontinuation.h kpair.h kgc.h kstring.h ksymbol.h \
kerror.h kghelpers.h kapplicative.h koperative.h kenvironment.h \
kgsymbols.h
kgsystem.o: kgsystem.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
- ktoken.h kmem.h kpair.h kgc.h kerror.h kghelpers.h kapplicative.h \
- koperative.h kcontinuation.h kenvironment.h ksymbol.h kstring.h \
- kgsystem.h
+ ktoken.h kmem.h kpair.h kgc.h kerror.h ksystem.h kghelpers.h \
+ kapplicative.h koperative.h kcontinuation.h kenvironment.h ksymbol.h \
+ kstring.h kgsystem.h
kgvectors.o: kgvectors.c kstate.h klimits.h klisp.h kobject.h klispconf.h \
ktoken.h kmem.h kapplicative.h koperative.h kcontinuation.h kerror.h \
- kpair.h kgc.h kvector.h kghelpers.h kenvironment.h ksymbol.h kstring.h \
- kgvectors.h kgnumbers.h kbytevector.h
+ kpair.h kgc.h kvector.h kbytevector.h kghelpers.h kenvironment.h \
+ ksymbol.h kstring.h kgvectors.h
kinteger.o: kinteger.c kinteger.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h imath.h kgc.h
klisp.o: klisp.c klimits.h klisp.h kobject.h klispconf.h kstate.h \
ktoken.h kmem.h kauxlib.h kstring.h kcontinuation.h koperative.h \
- kenvironment.h kport.h kread.h kwrite.h kerror.h kpair.h kgc.h \
- kgcontinuations.h kghelpers.h kapplicative.h ksymbol.h kgcontrol.h \
- krepl.h
+ kapplicative.h ksymbol.h kenvironment.h kport.h kread.h kwrite.h \
+ kerror.h kpair.h kgc.h krepl.h kghelpers.h
kmem.o: kmem.c klisp.h kobject.h klimits.h klispconf.h kstate.h ktoken.h \
kmem.h kerror.h kpair.h kgc.h
kobject.o: kobject.c kobject.h klimits.h klisp.h klispconf.h
@@ -274,23 +268,26 @@ kreal.o: kreal.c kreal.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
kerror.h
krepl.o: krepl.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
ktoken.h kmem.h kcontinuation.h kenvironment.h kerror.h kpair.h kgc.h \
- kread.h kwrite.h kstring.h krepl.h ksymbol.h kport.h kgerrors.h \
- kghelpers.h kapplicative.h koperative.h ktable.h kgcontinuations.h
+ kread.h kwrite.h kstring.h krepl.h ksymbol.h kport.h ktable.h \
+ kghelpers.h kapplicative.h koperative.h
kstate.o: kstate.c klisp.h kobject.h klimits.h klispconf.h kstate.h \
ktoken.h kmem.h kstring.h kpair.h kgc.h keval.h koperative.h \
kapplicative.h kcontinuation.h kenvironment.h kground.h krepl.h \
- ksymbol.h kport.h ktable.h kbytevector.h kvector.h \
- kgpairs_lists.h kghelpers.h kerror.h kgerrors.h
+ ksymbol.h kport.h ktable.h kbytevector.h kvector.h kghelpers.h kerror.h \
+ kgerrors.h
kstring.o: kstring.c kstring.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kgc.h
ksymbol.o: ksymbol.c ksymbol.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kstring.h kgc.h
-ksystem.o: ksystem.c ksystem.posix.c ksystem.win32.c kobject.h klimits.h klisp.h klispconf.h kstate.h \
- ktoken.h kmem.h ksystem.h
+ksystem.o: ksystem.c kobject.h klimits.h klisp.h klispconf.h kstate.h \
+ ktoken.h kmem.h kerror.h kpair.h kgc.h ksystem.h
+ksystem.posix.o: ksystem.posix.c kobject.h klimits.h klisp.h klispconf.h \
+ kstate.h ktoken.h kmem.h kinteger.h imath.h ksystem.h
+ksystem.win32.o: ksystem.win32.c kobject.h klimits.h klisp.h klispconf.h \
+ kstate.h ktoken.h kmem.h kinteger.h imath.h ksystem.h
ktable.o: ktable.c klisp.h kobject.h klimits.h klispconf.h kgc.h kstate.h \
- ktoken.h kmem.h ktable.h kapplicative.h koperative.h kgeqp.h kinteger.h \
- imath.h krational.h imrat.h kghelpers.h kerror.h kpair.h kcontinuation.h \
- kenvironment.h ksymbol.h kstring.h
+ ktoken.h kmem.h ktable.h kapplicative.h koperative.h kghelpers.h \
+ kerror.h kpair.h kcontinuation.h kenvironment.h ksymbol.h kstring.h
ktoken.o: ktoken.c ktoken.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h kmem.h kinteger.h imath.h krational.h imrat.h kreal.h kpair.h \
kgc.h kstring.h kbytevector.h ksymbol.h kerror.h kport.h
@@ -299,7 +296,7 @@ kvector.o: kvector.c kvector.h kobject.h klimits.h klisp.h klispconf.h \
kwrite.o: kwrite.c kwrite.h kobject.h klimits.h klisp.h klispconf.h \
kstate.h ktoken.h kmem.h kinteger.h imath.h krational.h imrat.h kreal.h \
kpair.h kgc.h kstring.h ksymbol.h kerror.h ktable.h kport.h \
- kenvironment.h kbytevector.h
+ kenvironment.h kbytevector.h kvector.h
imath.o: imath.c imath.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
ktoken.h kmem.h kerror.h kpair.h kgc.h
imrat.o: imrat.c imrat.h imath.h kobject.h klimits.h klisp.h klispconf.h \
diff --git a/src/kencapsulation.c b/src/kencapsulation.c
@@ -11,6 +11,11 @@
#include "kpair.h"
#include "kgc.h"
+bool kis_encapsulation_type(TValue enc, TValue key)
+{
+ return ttisencapsulation(enc) && tv_equal(kget_enc_key(enc), key);
+}
+
/* GC: Assumes that key & val are rooted */
TValue kmake_encapsulation(klisp_State *K, TValue key, TValue val)
{
diff --git a/src/kencapsulation.h b/src/kencapsulation.h
@@ -14,15 +14,9 @@
TValue kmake_encapsulation(klisp_State *K, TValue key, TValue val);
TValue kmake_encapsulation_key(klisp_State *K);
-inline bool kis_encapsulation_type(TValue enc, TValue key);
+bool kis_encapsulation_type(TValue enc, TValue key);
#define kget_enc_val(e_)(tv2enc(e_)->value)
#define kget_enc_key(e_)(tv2enc(e_)->key)
-inline bool kis_encapsulation_type(TValue enc, TValue key)
-{
- return ttisencapsulation(enc) && tv_equal(kget_enc_key(enc), key);
-}
-
-
#endif
diff --git a/src/kgbooleans.c b/src/kgbooleans.c
@@ -17,7 +17,9 @@
#include "ksymbol.h"
#include "kcontinuation.h"
#include "kerror.h"
+
#include "kghelpers.h"
+#include "kgbooleans.h"
/* 4.1.1 boolean? */
/* uses typep */
@@ -38,9 +40,6 @@ void notp(klisp_State *K)
kapply_cc(K, res);
}
-/* Helper for type checking booleans */
-bool kbooleanp(TValue obj) { return ttisboolean(obj); }
-
/* 6.1.2 and? */
void andp(klisp_State *K)
{
@@ -50,9 +49,9 @@ void andp(klisp_State *K)
klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
+ int32_t pairs;
/* don't care about cycle pairs */
- int32_t pairs = check_typed_list(K, "and?", "boolean", kbooleanp,
- true, ptree, NULL);
+ check_typed_list(K, kbooleanp, true, ptree, &pairs, NULL);
TValue res = KTRUE;
TValue tail = ptree;
while(pairs--) {
@@ -75,9 +74,9 @@ void orp(klisp_State *K)
klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
+ int32_t pairs;
/* don't care about cycle pairs */
- int32_t pairs = check_typed_list(K, "or?", "boolean", kbooleanp,
- true, ptree, NULL);
+ check_typed_list(K, kbooleanp,true, ptree, &pairs, NULL);
TValue res = KFALSE;
TValue tail = ptree;
while(pairs--) {
@@ -169,7 +168,7 @@ void Sandp_Sorp(klisp_State *K)
TValue sname = xparams[0];
TValue term_bool = xparams[1];
- TValue ls = check_copy_list(K, ksymbol_buf(sname), ptree, false);
+ TValue ls = check_copy_list(K, ptree, false, NULL, NULL);
/* This will work even if ls is empty */
krooted_tvs_push(K, ls);
TValue new_cont = kmake_continuation(K, kget_cc(K), do_Sandp_Sorp, 4,
diff --git a/src/kgbooleans.h b/src/kgbooleans.h
@@ -7,41 +7,7 @@
#ifndef kgbooleans_h
#define kgbooleans_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* 4.1.1 boolean? */
-/* uses typep */
-
-/* 6.1.1 not? */
-void notp(klisp_State *K);
-
-/* 6.1.2 and? */
-void andp(klisp_State *K);
-
-/* 6.1.3 or? */
-void orp(klisp_State *K);
-
-/* Helpers for $and? & $or? */
-void do_Sandp_Sorp(klisp_State *K);
-void Sandp_Sorp(klisp_State *K);
-
-/* 6.1.4 $and? */
-/* uses Sandp_Sorp */
-
-/* 6.1.5 $or? */
-/* uses Sandp_Sorp */
-
-/* Helper */
-bool kbooleanp(TValue obj);
/* init ground */
void kinit_booleans_ground_env(klisp_State *K);
diff --git a/src/kgbytevectors.c b/src/kgbytevectors.c
@@ -21,7 +21,6 @@
#include "kghelpers.h"
#include "kgbytevectors.h"
-#include "kgnumbers.h" /* for keintegerp & knegativep */
/* ?.? bytevector? */
/* uses typep */
@@ -33,10 +32,9 @@
/* GC: Assumes ls is rooted */
TValue list_to_bytevector_h(klisp_State *K, char *name, TValue ls)
{
- int32_t dummy;
/* don't allow cycles */
- int32_t pairs = check_typed_list(K, name, "u8", ku8p, false,
- ls, &dummy);
+ int32_t pairs;
+ check_typed_list(K, ku8p, false, ls, &pairs, NULL);
TValue new_bb;
/* the if isn't strictly necessary but it's clearer this way */
diff --git a/src/kgcombiners.c b/src/kgcombiners.c
@@ -21,13 +21,14 @@
#include "kerror.h"
#include "kghelpers.h"
-#include "kgpair_mut.h" /* for copy_es_immutable_h */
-#include "kgenv_mut.h" /* for match */
-#include "kgcontrol.h" /* for do_seq */
#include "kgcombiners.h"
-/* Helper (used by $vau & $lambda) */
+/* continuations */
void do_vau(klisp_State *K);
+void do_map_ret(klisp_State *K);
+void do_map_encycle(klisp_State *K);
+void do_map(klisp_State *K);
+void do_map_cycle(klisp_State *K);
/* 4.10.1 operative? */
/* uses typep */
@@ -47,13 +48,13 @@ void Svau(klisp_State *K)
bind_al2p(K, ptree, vptree, vpenv, vbody);
/* The ptree & body are copied to avoid mutation */
- vptree = check_copy_ptree(K, "$vau", vptree, vpenv);
+ vptree = check_copy_ptree(K, vptree, vpenv);
krooted_tvs_push(K, vptree);
/* the body should be a list */
- UNUSED(check_list(K, "$vau", true, vbody, NULL));
- vbody = copy_es_immutable_h(K, "$vau", vbody, false);
+ check_list(K, true, vbody, NULL, NULL);
+ vbody = copy_es_immutable_h(K, vbody, false);
krooted_tvs_push(K, vbody);
@@ -101,8 +102,7 @@ void do_vau(klisp_State *K)
/* protect env */
krooted_tvs_push(K, env);
- /* TODO use name from operative */
- match(K, "[user-operative]", env, op_ptree, ptree);
+ match(K, env, op_ptree, ptree);
if (!ttisignore(penv))
kadd_binding(K, env, penv, denv);
@@ -182,11 +182,11 @@ void Slambda(klisp_State *K)
bind_al1p(K, ptree, vptree, vbody);
/* The ptree & body are copied to avoid mutation */
- vptree = check_copy_ptree(K, "$lambda", vptree, KIGNORE);
+ vptree = check_copy_ptree(K, vptree, KIGNORE);
krooted_tvs_push(K, vptree);
/* the body should be a list */
- UNUSED(check_list(K, "$lambda", true, vbody, NULL));
- vbody = copy_es_immutable_h(K, "$lambda", vbody, false);
+ check_list(K, true, vbody, NULL, NULL);
+ vbody = copy_es_immutable_h(K, vbody, false);
krooted_tvs_push(K, vbody);
@@ -235,205 +235,6 @@ void apply(klisp_State *K)
ktail_eval(K, expr, env);
}
-/* Helpers for map (also used by for each) */
-void map_for_each_get_metrics(klisp_State *K, char *name, TValue lss,
- int32_t *app_apairs_out, int32_t *app_cpairs_out,
- int32_t *res_apairs_out, int32_t *res_cpairs_out)
-{
- /* avoid warnings (shouldn't happen if _No_return was used in throw) */
- *app_apairs_out = 0;
- *app_cpairs_out = 0;
- *res_apairs_out = 0;
- *res_cpairs_out = 0;
-
- /* get the metrics of the ptree of each call to app */
- int32_t app_cpairs;
- int32_t app_pairs = check_list(K, name, true, lss, &app_cpairs);
- int32_t app_apairs = app_pairs - app_cpairs;
-
- /* get the metrics of the result list */
- int32_t res_cpairs;
- /* We now that lss has at least one elem */
- int32_t res_pairs = check_list(K, name, true, kcar(lss), &res_cpairs);
- int32_t res_apairs = res_pairs - res_cpairs;
-
- if (res_cpairs == 0) {
- /* finite list of length res_pairs (all lists should
- have the same structure: acyclic with same length) */
- int32_t pairs = app_pairs - 1;
- TValue tail = kcdr(lss);
- while(pairs--) {
- int32_t first_cpairs;
- int32_t first_pairs = check_list(K, name, true, kcar(tail),
- &first_cpairs);
- tail = kcdr(tail);
-
- if (first_cpairs != 0) {
- klispE_throw_simple(K, "mixed finite and infinite lists");
- return;
- } else if (first_pairs != res_pairs) {
- klispE_throw_simple(K, "lists of different length");
- return;
- }
- }
- } else {
- /* cyclic list: all lists should be cyclic.
- result will have acyclic length equal to the
- max of all the lists and cyclic length equal to the lcm
- of all the lists. res_pairs may be broken but will be
- restored by after the loop */
- int32_t pairs = app_pairs - 1;
- TValue tail = kcdr(lss);
- while(pairs--) {
- int32_t first_cpairs;
- int32_t first_pairs = check_list(K, name, true, kcar(tail),
- &first_cpairs);
- int32_t first_apairs = first_pairs - first_cpairs;
- tail = kcdr(tail);
-
- if (first_cpairs == 0) {
- klispE_throw_simple(K, "mixed finite and infinite lists");
- return;
- }
- res_apairs = kmax32(res_apairs, first_apairs);
- /* this can throw an error if res_cpairs doesn't
- fit in 32 bits, which is a reasonable implementation
- restriction because the list wouldn't fit in memory
- anyways */
- res_cpairs = kcheck32(K, "map/for-each: result list is too big",
- klcm32_64(res_cpairs, first_cpairs));
- }
- res_pairs = kcheck32(K, "map/for-each: result list is too big",
- (int64_t) res_cpairs + (int64_t) res_apairs);
- UNUSED(res_pairs);
- }
-
- *app_apairs_out = app_apairs;
- *app_cpairs_out = app_cpairs;
- *res_apairs_out = res_apairs;
- *res_cpairs_out = res_cpairs;
-}
-
-/* Return two lists, isomorphic to lss: one list of cars and one list
- of cdrs (replacing the value of lss) */
-
-/* GC: assumes lss is rooted, and dummy1 & 2 are free in K */
-TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss,
- int32_t apairs, int32_t cpairs)
-{
- TValue tail = *lss;
-
- TValue lp_cars = kget_dummy1(K);
- TValue lap_cars = lp_cars;
-
- TValue lp_cdrs = kget_dummy2(K);
- TValue lap_cdrs = lp_cdrs;
-
- while(apairs != 0 || cpairs != 0) {
- int32_t pairs;
- if (apairs != 0) {
- pairs = apairs;
- } else {
- /* remember last acyclic pair of both lists to to encycle! later */
- lap_cars = lp_cars;
- lap_cdrs = lp_cdrs;
- pairs = cpairs;
- }
-
- while(pairs--) {
- TValue first = kcar(tail);
- tail = kcdr(tail);
-
- /* accumulate both cars and cdrs */
- TValue np;
- np = kcons(K, kcar(first), KNIL);
- kset_cdr(lp_cars, np);
- lp_cars = np;
-
- np = kcons(K, kcdr(first), KNIL);
- kset_cdr(lp_cdrs, np);
- lp_cdrs = np;
- }
-
- if (apairs != 0) {
- apairs = 0;
- } else {
- cpairs = 0;
- /* encycle! the list of cars and the list of cdrs */
- TValue fcp, lcp;
- fcp = kcdr(lap_cars);
- lcp = lp_cars;
- kset_cdr(lcp, fcp);
-
- fcp = kcdr(lap_cdrs);
- lcp = lp_cdrs;
- kset_cdr(lcp, fcp);
- }
- }
-
- *lss = kcutoff_dummy2(K);
- return kcutoff_dummy1(K);
-}
-
-/* Transpose lss so that the result is a list of lists, each one having
- metrics (app_apairs, app_cpairs). The metrics of the returned list
- should be (res_apairs, res_cpairs) */
-
-/* GC: assumes lss is rooted */
-TValue map_for_each_transpose(klisp_State *K, TValue lss,
- int32_t app_apairs, int32_t app_cpairs,
- int32_t res_apairs, int32_t res_cpairs)
-{
- /* reserve dummy1 & 2 to get_cars_cdrs */
- TValue lp = kget_dummy3(K);
- TValue lap = lp;
-
- TValue cars = KNIL; /* put something for GC */
- TValue tail = lss;
-
- /* GC: both cars & tail vary in each loop, to protect them we need
- the vars stack */
- krooted_vars_push(K, &cars);
- krooted_vars_push(K, &tail);
-
- /* Loop over list of lists, creating a list of cars and
- a list of cdrs, accumulate the list of cars and loop
- with the list of cdrs as the new list of lists (lss) */
- while(res_apairs != 0 || res_cpairs != 0) {
- int32_t pairs;
-
- if (res_apairs != 0) {
- pairs = res_apairs;
- } else {
- pairs = res_cpairs;
- /* remember last acyclic pair to encycle! later */
- lap = lp;
- }
-
- while(pairs--) {
- /* accumulate cars and replace tail with cdrs */
- cars = map_for_each_get_cars_cdrs(K, &tail, app_apairs, app_cpairs);
- TValue np = kcons(K, cars, KNIL);
- kset_cdr(lp, np);
- lp = np;
- }
-
- if (res_apairs != 0) {
- res_apairs = 0;
- } else {
- res_cpairs = 0;
- /* encycle! the list of list of cars */
- TValue fcp = kcdr(lap);
- TValue lcp = lp;
- kset_cdr(lcp, fcp);
- }
- }
-
- krooted_vars_pop(K);
- krooted_vars_pop(K);
- return kcutoff_dummy3(K);
-}
-
/* Continuation helpers for map */
/* For acyclic input lists: Return the mapped list */
@@ -451,7 +252,7 @@ void do_map_ret(klisp_State *K)
and later mutation of the result */
/* XXX: the check isn't necessary really, but there is
no list_copy */
- TValue copy = check_copy_list(K, "map", kcdr(xparams[0]), false);
+ TValue copy = check_copy_list(K, kcdr(xparams[0]), false, NULL, NULL);
kapply_cc(K, copy);
}
@@ -478,7 +279,7 @@ void do_map_encycle(klisp_State *K)
and later mutation of the result */
/* XXX: the check isn't necessary really, but there is
no list_copy */
- TValue copy = check_copy_list(K, "map", kcdr(xparams[0]), false);
+ TValue copy = check_copy_list(K, kcdr(xparams[0]), false, NULL, NULL);
kapply_cc(K, copy);
}
@@ -517,7 +318,7 @@ void do_map(klisp_State *K)
/* copy the ptree to avoid problems with mutation */
/* XXX: no check necessary, could just use copy_list if there
was such a procedure */
- TValue first_ptree = check_copy_list(K, "map", kcar(ls), false);
+ TValue first_ptree = check_copy_list(K, kcar(ls), false, NULL, NULL);
ls = kcdr(ls);
n = n-1;
krooted_tvs_push(K, first_ptree);
@@ -596,7 +397,90 @@ void map(klisp_State *K)
int32_t app_pairs, app_apairs, app_cpairs;
int32_t res_pairs, res_apairs, res_cpairs;
- map_for_each_get_metrics(K, "map", lss, &app_apairs, &app_cpairs,
+ map_for_each_get_metrics(K, lss, &app_apairs, &app_cpairs,
+ &res_apairs, &res_cpairs);
+ app_pairs = app_apairs + app_cpairs;
+ res_pairs = res_apairs + res_cpairs;
+
+ /* create the list of parameters to app */
+ lss = map_for_each_transpose(K, lss, app_apairs, app_cpairs,
+ res_apairs, res_cpairs);
+
+ /* ASK John: the semantics when this is mixed with continuations,
+ isn't all that great..., but what are the expectations considering
+ there is no prescribed order? */
+
+ krooted_tvs_push(K, lss);
+ /* This will be the list to be returned, but it will be copied
+ before to play a little nicer with continuations */
+ TValue dummy = kcons(K, KINERT, KNIL);
+
+ krooted_tvs_push(K, dummy);
+
+ TValue ret_cont = (res_cpairs == 0)?
+ kmake_continuation(K, kget_cc(K), do_map_ret, 1, dummy)
+ : kmake_continuation(K, kget_cc(K), do_map_cycle, 4,
+ app, dummy, i2tv(res_cpairs), denv);
+
+ krooted_tvs_push(K, ret_cont);
+
+ /* schedule the mapping of the elements of the acyclic part.
+ signal dummyp = true to avoid creating a pair for
+ the inert value passed to the first continuation */
+ TValue new_cont =
+ kmake_continuation(K, ret_cont, do_map, 6, app, lss, dummy,
+ i2tv(res_apairs), denv, KTRUE);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
+ kset_cc(K, new_cont);
+
+ /* this will be a nop, and will continue with do_map */
+ kapply_cc(K, KINERT);
+}
+
+/*
+** These are from r7rs (except bytevector). For now just follow
+** Kernel version of (list) map. That means that the objects should
+** all have the same size, and that the dynamic environment is passed
+** to the applicatives. Continuation capturing interaction is still
+** an open issue (see comment in map).
+*/
+
+/* 5.9.? string-map */
+/* 5.9.? vector-map */
+/* 5.9.? bytevector-map */
+void array_map(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+
+ /*
+ ** xparams[0]: array->list fn
+ ** xparams[1]: list->array fn
+ ** xparams[2]: type name
+ */
+
+ UNUSED(xparams);
+
+/* TODO */
+ bind_al1tp(K, ptree, "applicative", ttisapplicative, app, lss);
+
+ if (ttisnil(lss)) {
+ klispE_throw_simple(K, "no lists");
+ return;
+ }
+
+ /* get the metrics of the ptree of each call to app and
+ of the result list */
+ int32_t app_pairs, app_apairs, app_cpairs;
+ int32_t res_pairs, res_apairs, res_cpairs;
+
+ map_for_each_get_metrics(K, lss, &app_apairs, &app_cpairs,
&res_apairs, &res_cpairs);
app_pairs = app_apairs + app_cpairs;
res_pairs = res_apairs + res_cpairs;
@@ -643,9 +527,6 @@ void map(klisp_State *K)
/* 6.2.1 combiner? */
/* uses ftypedp */
-/* Helper for combiner? */
-bool kcombinerp(TValue obj) { return ttiscombiner(obj); }
-
/* init ground */
void kinit_combiners_ground_env(klisp_State *K)
{
diff --git a/src/kgcombiners.h b/src/kgcombiners.h
@@ -7,81 +7,7 @@
#ifndef kgcombiners_h
#define kgcombiners_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* 4.10.1 operative? */
-/* uses typep */
-
-/* 4.10.2 applicative? */
-/* uses typep */
-
-/* 4.10.3 $vau */
-/* 5.3.1 $vau */
-void Svau(klisp_State *K);
-
-/* 4.10.4 wrap */
-void wrap(klisp_State *K);
-
-/* 4.10.5 unwrap */
-void unwrap(klisp_State *K);
-
-/* 5.3.1 $vau */
-/* DONE: above, together with 4.10.4 */
-
-/* 5.3.2 $lambda */
-void Slambda(klisp_State *K);
-
-/* 5.5.1 apply */
-void apply(klisp_State *K);
-
-/* Helpers for map (also used by for each) */
-
-/* Calculate the metrics for both the result list and the ptree
- passed to the applicative */
-void map_for_each_get_metrics(
- klisp_State *K, char *name, TValue lss, int32_t *app_apairs_out,
- int32_t *app_cpairs_out, int32_t *res_apairs_out, int32_t *res_cpairs_out);
-
-/* Return two lists, isomorphic to lss: one list of cars and one list
- of cdrs (replacing the value of lss) */
-/* GC: Assumes lss is rooted, uses dummys 2 & 3 */
-TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss,
- int32_t apairs, int32_t cpairs);
-
-/* Transpose lss so that the result is a list of lists, each one having
- metrics (app_apairs, app_cpairs). The metrics of the returned list
- should be (res_apairs, res_cpairs) */
-
-/* GC: Assumes lss is rooted, uses dummys 1, &
- (through get_cars_cdrs, 2, 3) */
-TValue map_for_each_transpose(klisp_State *K, TValue lss,
- int32_t app_apairs, int32_t app_cpairs,
- int32_t res_apairs, int32_t res_cpairs);
-
-/* 5.9.1 map */
-void map(klisp_State *K);
-
-/* 6.2.1 combiner? */
-/* uses ftypedp */
-
-/* Helper for combiner? */
-bool kcombinerp(TValue obj);
-
-
-void do_vau(klisp_State *K);
-void do_map_ret(klisp_State *K);
-void do_map_encycle(klisp_State *K);
-void do_map(klisp_State *K);
-void do_map_cycle(klisp_State *K);
/* init ground */
void kinit_combiners_ground_env(klisp_State *K);
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -22,7 +22,6 @@
#include "kghelpers.h"
#include "kgcontinuations.h"
-#include "kgcontrol.h" /* for seq helpers in $let/cc */
/* 7.1.1 continuation? */
/* uses typep */
@@ -84,92 +83,6 @@ void extend_continuation(klisp_State *K)
kapply_cc(K, new_cont);
}
-/* Helpers for guard-continuation (& guard-dynamic-extent) */
-
-/* this is used for inner & outer continuations, it just
- passes the value. xparams is not actually empty, it contains
- the entry/exit guards, but they are used only in
- continuation->applicative (that is during abnormal passes) */
-void do_pass_value(klisp_State *K)
-{
- TValue *xparams = K->next_xparams;
- TValue obj = K->next_value;
- klisp_assert(ttisnil(K->next_env));
- UNUSED(xparams);
- kapply_cc(K, obj);
-}
-
-#define singly_wrapped(obj_) (ttisapplicative(obj_) && \
- ttisoperative(kunwrap(obj_)))
-
-/* this unmarks root before throwing any error */
-/* TODO: this isn't very clean, refactor */
-
-/* GC: assumes obj & root are rooted, dummy1 is in use */
-inline TValue check_copy_single_entry(klisp_State *K, char *name,
- TValue obj, TValue root)
-{
- if (!ttispair(obj) || !ttispair(kcdr(obj)) ||
- !ttisnil(kcddr(obj))) {
- unmark_list(K, root);
- klispE_throw_simple(K, "Bad entry (expected list of length 2)");
- return KINERT;
- }
- TValue cont = kcar(obj);
- TValue app = kcadr(obj);
-
- if (!ttiscontinuation(cont)) {
- unmark_list(K, root);
- klispE_throw_simple(K, "Bad type on first element (expected "
- "continuation)");
- return KINERT;
- } else if (!singly_wrapped(app)) {
- unmark_list(K, root);
- klispE_throw_simple(K, "Bad type on second element (expected "
- "singly wrapped applicative)");
- return KINERT;
- }
-
- /* save the operative directly, don't waste space/time
- with a list, use just a pair */
- return kcons(K, cont, kunwrap(app));
-}
-
-/* the guards are probably generated on the spot so we don't check
- for immutability and copy it anyways */
-/* GC: Assumes obj is rooted */
-TValue check_copy_guards(klisp_State *K, char *name, TValue obj)
-{
- if (ttisnil(obj)) {
- return obj;
- } else {
- TValue last_pair = kget_dummy1(K);
- TValue tail = obj;
-
- while(ttispair(tail) && !kis_marked(tail)) {
- /* this will clear the marks and throw an error if the structure
- is incorrect */
- TValue entry = check_copy_single_entry(K, name, kcar(tail), obj);
- krooted_tvs_push(K, entry);
- TValue new_pair = kcons(K, entry, KNIL);
- krooted_tvs_pop(K);
- kmark(tail);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- tail = kcdr(tail);
- }
-
- /* dont close the cycle (if there is one) */
- unmark_list(K, obj);
- TValue ret = kcutoff_dummy1(K);
- if (!ttispair(tail) && !ttisnil(tail)) {
- klispE_throw_simple(K, "expected list");
- return KINERT;
- }
- return ret;
- }
-}
-
/* 7.2.4 guard-continuation */
void guard_continuation(klisp_State *K)
{
@@ -280,7 +193,7 @@ void Slet_cc(klisp_State *K)
/* the list of instructions is copied to avoid mutation */
/* MAYBE: copy the evaluation structure, ASK John */
- TValue ls = check_copy_list(K, "$let/cc", objs, false);
+ TValue ls = check_copy_list(K, objs, false, NULL, NULL);
krooted_tvs_push(K, ls);
/* this is needed because seq continuation doesn't check for
@@ -300,45 +213,7 @@ void Slet_cc(klisp_State *K)
}
/* 7.3.3 guard-dynamic-extent */
-void guard_dynamic_extent(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);
-
- bind_3tp(K, ptree, "any", anytype, entry_guards,
- "combiner", ttiscombiner, comb,
- "any", anytype, exit_guards);
-
- entry_guards = check_copy_guards(K, "guard-dynamic-extent: entry guards",
- entry_guards);
- krooted_tvs_push(K, entry_guards);
- exit_guards = check_copy_guards(K, "guard-dynamic-extent: exit guards",
- exit_guards);
- krooted_tvs_push(K, exit_guards);
- /* GC: root continuations */
- /* The current continuation is guarded */
- TValue outer_cont = kmake_continuation(K, kget_cc(K), do_pass_value,
- 2, entry_guards, denv);
- kset_outer_cont(outer_cont);
- kset_cc(K, outer_cont); /* this implicitly roots outer_cont */
-
- TValue inner_cont = kmake_continuation(K, outer_cont, do_pass_value, 2,
- exit_guards, denv);
- kset_inner_cont(inner_cont);
-
- /* call combiner with no operands in the dynamic extent of inner,
- with the dynamic env of this call */
- kset_cc(K, inner_cont); /* this implicitly roots inner_cont */
- TValue expr = kcons(K, comb, KNIL);
-
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
-
- ktail_eval(K, expr, denv);
-}
+/* in kghelpers */
/* 7.3.4 exit */
/* Unlike in the report, in klisp this takes an optional argument
diff --git a/src/kgcontinuations.h b/src/kgcontinuations.h
@@ -7,54 +7,7 @@
#ifndef kgcontinuations_h
#define kgcontinuations_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* Helpers (also used in keyed dynamic code) */
-void do_pass_value(klisp_State *K);
-
-/* 7.1.1 continuation? */
-/* uses typep */
-
-/* 7.2.2 call/cc */
-void call_cc(klisp_State *K);
-
-/* 7.2.3 extend-continuation */
-void extend_continuation(klisp_State *K);
-
-/* 7.2.4 guard-continuation */
-void guard_continuation(klisp_State *K);
-
-/* 7.2.5 continuation->applicative */
-void continuation_applicative(klisp_State *K);
-
-/* 7.2.6 root-continuation */
-/* done in kground.c/krepl.c */
-
-/* 7.2.7 error-continuation */
-/* done in kground.c/krepl.c */
-
-/* 7.3.1 apply-continuation */
-void apply_continuation(klisp_State *K);
-
-/* 7.3.2 $let/cc */
-void Slet_cc(klisp_State *K);
-
-/* 7.3.3 guard-dynamic-extent */
-void guard_dynamic_extent(klisp_State *K);
-
-/* 7.3.4 exit */
-void kgexit(klisp_State *K);
-
-void do_extended_cont(klisp_State *K);
/* init ground */
void kinit_continuations_ground_env(klisp_State *K);
diff --git a/src/kgcontrol.c b/src/kgcontrol.c
@@ -18,7 +18,6 @@
#include "kghelpers.h"
#include "kgcontrol.h"
-#include "kgcombiners.h" /* for map/for-each helpers */
/* 4.5.1 inert? */
/* uses typep */
@@ -86,7 +85,7 @@ void Ssequence(klisp_State *K)
} else {
/* the list of instructions is copied to avoid mutation */
/* MAYBE: copy the evaluation structure, ASK John */
- TValue ls = check_copy_list(K, "$sequence", ptree, false);
+ TValue ls = check_copy_list(K, ptree, false, NULL, NULL);
/* this is needed because seq continuation doesn't check for
nil sequence */
/* TODO this could be at least in an inlineable function to
@@ -108,37 +107,6 @@ void Ssequence(klisp_State *K)
}
}
-/* Helper (also used by $vau and $lambda) */
-/* the remaining list can't be null, that case is managed before */
-void do_seq(klisp_State *K)
-{
- TValue *xparams = K->next_xparams;
- TValue obj = K->next_value;
- klisp_assert(ttisnil(K->next_env));
-
- UNUSED(obj);
-
- /*
- ** xparams[0]: remaining list
- ** xparams[1]: dynamic environment
- */
- TValue ls = xparams[0];
- TValue first = kcar(ls);
- TValue tail = kcdr(ls);
- TValue denv = xparams[1];
-
- if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2, tail,
- denv);
- kset_cc(K, new_cont);
-#if KTRACK_SI
- /* put the source info of the list including the element
- that we are about to evaluate */
- kset_source_info(K, new_cont, ktry_get_si(K, ls));
-#endif
- }
- ktail_eval(K, first, denv);
-}
/* Helpers for cond */
@@ -204,7 +172,7 @@ TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
while(count--) {
TValue first = kcar(tail);
/* this uses dummy3 */
- TValue copy = check_copy_list(K, "$cond", first, false);
+ TValue copy = check_copy_list(K, first, false, NULL, NULL);
kset_car(tail, copy);
tail = kcdr(tail);
}
@@ -339,7 +307,7 @@ void do_for_each(klisp_State *K)
/* copy the ptree to avoid problems with mutation */
/* XXX: no check necessary, could just use copy_list if there
was such a procedure */
- TValue first_ptree = check_copy_list(K, "for-each", kcar(ls), false);
+ TValue first_ptree = check_copy_list(K, kcar(ls), false, NULL, NULL);
krooted_tvs_push(K, first_ptree);
ls = kcdr(ls);
n = n-1;
@@ -376,7 +344,7 @@ void for_each(klisp_State *K)
int32_t app_pairs, app_apairs, app_cpairs;
int32_t res_pairs, res_apairs, res_cpairs;
- map_for_each_get_metrics(K, "for-each", lss, &app_apairs, &app_cpairs,
+ map_for_each_get_metrics(K, lss, &app_apairs, &app_cpairs,
&res_apairs, &res_cpairs);
app_pairs = app_apairs + app_cpairs;
res_pairs = res_apairs + res_cpairs;
diff --git a/src/kgcontrol.h b/src/kgcontrol.h
@@ -7,42 +7,7 @@
#ifndef kgcontrol_h
#define kgcontrol_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* 4.5.1 inert? */
-/* uses typep */
-
-/* 4.5.2 $if */
-
-void Sif(klisp_State *K);
-
-/* 5.1.1 $sequence */
-void Ssequence(klisp_State *K);
-
-/* Helpers for $cond */
-TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
- TValue *bodies);
-
-
-/* 5.6.1 $cond */
-void Scond(klisp_State *K);
-
-/* 6.9.1 for-each */
-void for_each(klisp_State *K);
-
-void do_seq(klisp_State *K);
-void do_cond(klisp_State *K);
-void do_select_clause(klisp_State *K);
-void do_for_each(klisp_State *K);
/* init ground */
void kinit_control_ground_env(klisp_State *K);
diff --git a/src/kgencapsulations.c b/src/kgencapsulations.c
@@ -23,39 +23,7 @@
/* Helpers for make-encapsulation-type */
/* Type predicate for encapsulations */
-void enc_typep(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(denv);
- /*
- ** xparams[0]: encapsulation key
- */
- TValue key = xparams[0];
-
- /* check the ptree is a list while checking the predicate.
- Keep going even if the result is false to catch errors in
- ptree structure */
- bool res = true;
-
- TValue tail = ptree;
- while(ttispair(tail) && kis_unmarked(tail)) {
- kmark(tail);
- res &= kis_encapsulation_type(kcar(tail), key);
- tail = kcdr(tail);
- }
- unmark_list(K, ptree);
-
- if (ttispair(tail) || ttisnil(tail)) {
- kapply_cc(K, b2tv(res));
- } else {
- /* try to get name from encapsulation */
- klispE_throw_simple(K, "expected list");
- return;
- }
-}
+/* enc_typep(klisp_State *K), in kghelpers */
/* Constructor for encapsulations */
void enc_wrap(klisp_State *K)
diff --git a/src/kgencapsulations.h b/src/kgencapsulations.h
@@ -7,22 +7,7 @@
#ifndef kgencapsulations_h
#define kgencapsulations_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* needed by kgffi.c */
-void enc_typep(klisp_State *K);
-
-/* 8.1.1 make-encapsulation-type */
-void make_encapsulation_type(klisp_State *K);
/* init ground */
void kinit_encapsulations_ground_env(klisp_State *K);
diff --git a/src/kgenv_mut.c b/src/kgenv_mut.c
@@ -20,7 +20,10 @@
#include "kghelpers.h"
#include "kgenv_mut.h"
-#include "kgcontrol.h" /* for do_seq */
+
+/* continuations */
+void do_match(klisp_State *K);
+void do_set_eval_obj(klisp_State *K);
/* 4.9.1 $define! */
void SdefineB(klisp_State *K)
@@ -36,7 +39,7 @@ void SdefineB(klisp_State *K)
TValue def_sym = xparams[0];
- dptree = check_copy_ptree(K, "$define!", dptree, KIGNORE);
+ dptree = check_copy_ptree(K, dptree, KIGNORE);
krooted_tvs_push(K, dptree);
@@ -61,9 +64,8 @@ void do_match(klisp_State *K)
*/
TValue ptree = xparams[0];
TValue env = xparams[1];
- char *name = ksymbol_buf(xparams[2]);
- match(K, name, env, ptree, obj);
+ match(K, env, ptree, obj);
kapply_cc(K, KINERT);
}
@@ -80,7 +82,7 @@ void SsetB(klisp_State *K)
bind_3p(K, ptree, env_exp, raw_formals, eval_exp);
- TValue formals = check_copy_ptree(K, "$set!", raw_formals, KIGNORE);
+ TValue formals = check_copy_ptree(K, raw_formals, KIGNORE);
krooted_tvs_push(K, formals);
TValue new_cont =
@@ -143,7 +145,7 @@ inline void unmark_maybe_symbol_list(klisp_State *K, TValue ls)
** returns a copy of the list (cf. check_copy_ptree)
*/
/* GC: Assumes obj is rooted, uses dummy1 */
-TValue check_copy_symbol_list(klisp_State *K, char *name, TValue obj)
+TValue check_copy_symbol_list(klisp_State *K, TValue obj)
{
TValue tail = obj;
bool type_errorp = false;
@@ -173,7 +175,6 @@ TValue check_copy_symbol_list(klisp_State *K, char *name, TValue obj)
klispE_throw_simple(K, "expected finite list");
return KNIL;
} else if (type_errorp) {
- /* TODO put type name too */
klispE_throw_simple(K, "bad operand type (expected list of "
"symbols)");
return KNIL;
@@ -222,13 +223,12 @@ void SprovideB(klisp_State *K)
** xparams[0]: name as symbol
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
bind_al1p(K, ptree, symbols, body);
- symbols = check_copy_symbol_list(K, name, symbols);
+ symbols = check_copy_symbol_list(K, symbols);
krooted_tvs_push(K, symbols);
- body = check_copy_list(K, name, body, false);
+ body = check_copy_list(K, body, false, NULL, NULL);
krooted_tvs_push(K, body);
TValue new_env = kmake_environment(K, denv);
@@ -293,11 +293,10 @@ void SimportB(klisp_State *K)
** xparams[0]: name as symbol
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
bind_al1p(K, ptree, env_expr, symbols);
- symbols = check_copy_symbol_list(K, name, symbols);
+ symbols = check_copy_symbol_list(K, symbols);
/* REFACTOR/ASK John: another way for this kind of operative would be
to first eval the env expression and only then check the type
diff --git a/src/kgenv_mut.h b/src/kgenv_mut.h
@@ -7,248 +7,7 @@
#ifndef kgenv_mut_h
#define kgenv_mut_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* helpers */
-inline void match(klisp_State *K, char *name, TValue env, TValue ptree,
- TValue obj);
-void do_match(klisp_State *K);
-inline void ptree_clear_all(klisp_State *K, TValue sym_ls);
-inline TValue check_copy_ptree(klisp_State *K, char *name, TValue ptree,
- TValue penv);
-/* 4.9.1 $define! */
-void SdefineB(klisp_State *K);
-
-/* MAYBE: don't make these inline */
-/*
-** Clear all the marks (symbols + pairs) & stacks.
-** The stack should contain only pairs, sym_ls should be
-** as above
-*/
-inline void ptree_clear_all(klisp_State *K, TValue sym_ls)
-{
- while(!ttisnil(sym_ls)) {
- TValue first = sym_ls;
- sym_ls = kget_symbol_mark(first);
- kunmark_symbol(first);
- }
-
- while(!ks_sisempty(K)) {
- kunmark(ks_sget(K));
- ks_sdpop(K);
- }
-
- ks_tbclear(K);
-}
-
-/* GC: assumes env, ptree & obj are rooted */
-inline void match(klisp_State *K, char *name, TValue env, TValue ptree,
- TValue obj)
-{
- assert(ks_sisempty(K));
- ks_spush(K, obj);
- ks_spush(K, ptree);
-
- while(!ks_sisempty(K)) {
- ptree = ks_spop(K);
- obj = ks_spop(K);
-
- switch(ttype(ptree)) {
- case K_TNIL:
- if (!ttisnil(obj)) {
- /* TODO show ptree and arguments */
- ks_sclear(K);
- klispE_throw_simple(K, "ptree doesn't match arguments");
- return;
- }
- break;
- case K_TIGNORE:
- /* do nothing */
- break;
- case K_TSYMBOL:
- kadd_binding(K, env, ptree, obj);
- break;
- case K_TPAIR:
- if (ttispair(obj)) {
- ks_spush(K, kcdr(obj));
- ks_spush(K, kcdr(ptree));
- ks_spush(K, kcar(obj));
- ks_spush(K, kcar(ptree));
- } else {
- /* TODO show ptree and arguments */
- ks_sclear(K);
- klispE_throw_simple(K, "ptree doesn't match arguments");
- return;
- }
- break;
- default:
- /* can't really happen */
- break;
- }
- }
-}
-
-/* GC: assumes ptree & penv are rooted */
-inline TValue check_copy_ptree(klisp_State *K, char *name, TValue ptree,
- TValue penv)
-{
- /* copy is only valid if the state isn't ST_PUSH */
- /* but init anyways for gc (and avoiding warnings) */
- TValue copy = ptree;
- krooted_vars_push(K, ©);
-
- /*
- ** NIL terminated singly linked list of symbols
- ** (using the mark as next pointer)
- */
- TValue sym_ls = KNIL;
-
- assert(ks_sisempty(K));
- assert(ks_tbisempty(K));
-
- ks_tbpush(K, ST_PUSH);
- ks_spush(K, ptree);
-
- while(!ks_sisempty(K)) {
- char state = ks_tbpop(K);
- TValue top = ks_spop(K);
-
- if (state == ST_PUSH) {
- switch(ttype(top)) {
- case K_TIGNORE:
- case K_TNIL:
- copy = top;
- break;
- case K_TSYMBOL: {
- if (kis_symbol_marked(top)) {
- ptree_clear_all(K, sym_ls);
- klispE_throw_simple_with_irritants(K, "repeated symbol "
- "in ptree", 1, top);
- return KNIL;
- } else {
- copy = top;
- /* add it to the symbol list */
- kset_symbol_mark(top, sym_ls);
- sym_ls = top;
- }
- break;
- }
- case K_TPAIR: {
- if (kis_unmarked(top)) {
- if (kis_immutable(top)) {
- /* don't copy mutable pairs, just use them */
- /* NOTE: immutable pairs can't have mutable
- car or cdr */
- /* we have to continue thou, because there could be a
- cycle */
- kset_mark(top, top);
- } else {
- /* create a new pair as copy, save it in the mark */
- TValue new_pair = kimm_cons(K, KNIL, KNIL);
- kset_mark(top, new_pair);
- /* copy the source code info */
- TValue si = ktry_get_si(K, top);
- if (!ttisnil(si))
- kset_source_info(K, new_pair, si);
- }
- /* keep the old pair and continue with the car */
- ks_tbpush(K, ST_CAR);
- ks_spush(K, top);
-
- ks_tbpush(K, ST_PUSH);
- ks_spush(K, kcar(top));
- } else {
- /* marked pair means a cycle was found */
- /* NOTE: the pair should be in the stack already so
- it isn't necessary to push it again to clear the mark */
- ptree_clear_all(K, sym_ls);
- klispE_throw_simple(K, "cycle detected in ptree");
- /* avoid warning */
- return KNIL;
- }
- break;
- }
- default:
- ptree_clear_all(K, sym_ls);
- klispE_throw_simple(K, "bad object type in ptree");
- /* avoid warning */
- return KNIL;
- }
- } else {
- /* last operation was a pop */
- /* top is a marked pair, the mark is the copied obj */
- /* NOTE: if top is immutable the mark is also top
- we could still do the set-car/set-cdr because the
- copy would be the same as the car/cdr, but why bother */
- if (state == ST_CAR) {
- /* only car was checked (not yet copied) */
- if (kis_mutable(top)) {
- TValue copied_pair = kget_mark(top);
- /* copied_pair may be immutable */
- kset_car_unsafe(K, copied_pair, copy);
- }
- /* put the copied pair again, continue with the cdr */
- ks_tbpush(K, ST_CDR);
- ks_spush(K, top);
-
- ks_tbpush(K, ST_PUSH);
- ks_spush(K, kcdr(top));
- } else {
- /* both car & cdr were checked (cdr not yet copied) */
- TValue copied_pair = kget_mark(top);
- /* the unmark is needed to allow diamonds */
- kunmark(top);
-
- if (kis_mutable(top)) {
- /* copied_pair may be immutable */
- kset_cdr_unsafe(K, copied_pair, copy);
- }
- copy = copied_pair;
- }
- }
- }
-
- if (ttissymbol(penv)) {
- if (kis_symbol_marked(penv)) {
- ptree_clear_all(K, sym_ls);
- klispE_throw_simple_with_irritants(K, "same symbol in both ptree "
- "and environment parameter",
- 1, sym_ls);
- }
- } else if (!ttisignore(penv)) {
- ptree_clear_all(K, sym_ls);
- klispE_throw_simple(K, "symbol or #ignore expected as "
- "environment parmameter");
- }
- ptree_clear_all(K, sym_ls);
- krooted_vars_pop(K);
- return copy;
-}
-
-/* 6.8.1 $set! */
-void SsetB(klisp_State *K);
-
-/* Helper for $set! */
-void do_set_eval_obj(klisp_State *K);
-
-/* Helpers for $provide & $import! */
-TValue check_copy_symbol_list(klisp_State *K, char *name, TValue obj);
-void do_import(klisp_State *K);
-
-/* 6.8.2 $provide! */
-void SprovideB(klisp_State *K);
-
-/* 6.8.3 $import! */
-void SimportB(klisp_State *K);
/* init ground */
void kinit_env_mut_ground_env(klisp_State *K);
diff --git a/src/kgenvironments.c b/src/kgenvironments.c
@@ -20,10 +20,9 @@
#include "kghelpers.h"
#include "kgenvironments.h"
-#include "kgenv_mut.h" /* for check_ptree */
-#include "kgpair_mut.h" /* for copy_es_immutable_h */
-#include "kgcontrol.h" /* for do_seq */
-/* MAYBE: move the above to kghelpers.h */
+
+/* continuations */
+void do_remote_eval(klisp_State *K);
/* 4.8.1 environment? */
/* uses typep */
@@ -75,7 +74,7 @@ void make_environment(klisp_State *K)
} else {
/* this is the general case, copy the list but without the
cycle if there is any */
- TValue parents = check_copy_env_list(K, "make-environment", ptree);
+ TValue parents = check_copy_env_list(K, ptree);
krooted_tvs_push(K, parents);
new_env = kmake_environment(K, parents);
krooted_tvs_pop(K);
@@ -98,7 +97,7 @@ void make_environment(klisp_State *K)
*/
/* GC: assume bindings is rooted, uses dummys 1 & 2 */
-TValue split_check_let_bindings(klisp_State *K, char *name, TValue bindings,
+TValue split_check_let_bindings(klisp_State *K, TValue bindings,
TValue *exprs, bool starp)
{
TValue last_car_pair = kget_dummy1(K);
@@ -142,14 +141,14 @@ TValue split_check_let_bindings(klisp_State *K, char *name, TValue bindings,
tail = kget_dummy1_tail(K);
while(!ttisnil(tail)) {
TValue first = kcar(tail);
- TValue copy = check_copy_ptree(K, name, first, KIGNORE);
+ TValue copy = check_copy_ptree(K, first, KIGNORE);
kset_car(tail, copy);
tail = kcdr(tail);
}
res = kget_dummy1_tail(K);
} else {
/* all bindings are consider one ptree in these 'let's */
- res = check_copy_ptree(K, name, kget_dummy1_tail(K), KIGNORE);
+ res = check_copy_ptree(K, kget_dummy1_tail(K), KIGNORE);
}
*exprs = kcutoff_dummy2(K);
UNUSED(kcutoff_dummy1(K));
@@ -177,7 +176,6 @@ void do_let(klisp_State *K)
** xparams[6]: body
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
TValue ptree = xparams[1];
TValue bindings = xparams[2];
TValue exprs = xparams[3];
@@ -185,7 +183,7 @@ void do_let(klisp_State *K)
bool recp = bvalue(xparams[5]);
TValue body = xparams[6];
- match(K, name, env, ptree, obj);
+ match(K, env, ptree, obj);
if (ttisnil(bindings)) {
if (ttisnil(body)) {
@@ -231,16 +229,15 @@ void Slet(klisp_State *K)
** xparams[0]: symbol name
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
bind_al1p(K, ptree, bindings, body);
TValue exprs;
- TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, false);
+ TValue bptree = split_check_let_bindings(K, bindings, &exprs, false);
krooted_tvs_push(K, bptree);
krooted_tvs_push(K, exprs);
- UNUSED(check_list(K, name, true, body, NULL));
- body = copy_es_immutable_h(K, name, body, false);
+ check_list(K, true, body, NULL, NULL);
+ body = copy_es_immutable_h(K, body, false);
krooted_tvs_push(K, body);
TValue new_env = kmake_environment(K, denv);
@@ -304,9 +301,9 @@ void Sbindsp(klisp_State *K)
bind_al1p(K, ptree, env_expr, symbols);
/* REFACTOR replace with single function check_copy_typed_list */
- int32_t count = check_typed_list(K, "$binds?", "symbol", ksymbolp,
- true, symbols, NULL);
- symbols = check_copy_list(K, "$binds?", symbols, false);
+ int32_t count;
+ check_typed_list(K, ksymbolp, true, symbols, &count, NULL);
+ symbols = check_copy_list(K, symbols, false, NULL, NULL);
krooted_tvs_push(K, symbols);
TValue new_cont = kmake_continuation(K, kget_cc(K), do_bindsp,
@@ -356,15 +353,14 @@ void SletS(klisp_State *K)
** xparams[0]: symbol name
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
bind_al1p(K, ptree, bindings, body);
TValue exprs;
- TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, true);
+ TValue bptree = split_check_let_bindings(K, bindings, &exprs, true);
krooted_tvs_push(K, exprs);
krooted_tvs_push(K, bptree);
- UNUSED(check_list(K, name, true, body, NULL));
- body = copy_es_immutable_h(K, name, body, false);
+ check_list(K, true, body, NULL, NULL);
+ body = copy_es_immutable_h(K, body, false);
krooted_tvs_push(K, body);
TValue new_env = kmake_environment(K, denv);
@@ -409,16 +405,15 @@ void Sletrec(klisp_State *K)
** xparams[0]: symbol name
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
bind_al1p(K, ptree, bindings, body);
TValue exprs;
- TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, false);
+ TValue bptree = split_check_let_bindings(K, bindings, &exprs, false);
krooted_tvs_push(K, exprs);
krooted_tvs_push(K, bptree);
- UNUSED(check_list(K, name, true, body, NULL));
- body = copy_es_immutable_h(K, name, body, false);
+ check_list(K, true, body, NULL, NULL);
+ body = copy_es_immutable_h(K, body, false);
krooted_tvs_push(K, body);
TValue new_env = kmake_environment(K, denv);
@@ -450,15 +445,14 @@ void SletrecS(klisp_State *K)
** xparams[0]: symbol name
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
bind_al1p(K, ptree, bindings, body);
TValue exprs;
- TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, true);
+ TValue bptree = split_check_let_bindings(K, bindings, &exprs, true);
krooted_tvs_push(K, exprs);
krooted_tvs_push(K, bptree);
- UNUSED(check_list(K, name, true, body, NULL));
- body = copy_es_immutable_h(K, name, body, false);
+ check_list(K, true, body, NULL, NULL);
+ body = copy_es_immutable_h(K, body, false);
krooted_tvs_push(K, body);
TValue new_env = kmake_environment(K, denv);
@@ -538,16 +532,15 @@ void Slet_redirect(klisp_State *K)
** xparams[0]: symbol name
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
bind_al2p(K, ptree, env_exp, bindings, body);
TValue exprs;
- TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, false);
+ TValue bptree = split_check_let_bindings(K, bindings, &exprs, false);
krooted_tvs_push(K, exprs);
krooted_tvs_push(K, bptree);
- UNUSED(check_list(K, name, true, body, NULL));
- body = copy_es_immutable_h(K, name, body, false);
+ check_list(K, true, body, NULL, NULL);
+ body = copy_es_immutable_h(K, body, false);
krooted_tvs_push(K, body);
TValue eexpr = kcons(K, K->list_app, exprs);
@@ -577,17 +570,16 @@ void Slet_safe(klisp_State *K)
** xparams[0]: symbol name
*/
TValue sname = xparams[0];
- char *name = ksymbol_buf(sname);
bind_al1p(K, ptree, bindings, body);
TValue exprs;
- TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, false);
+ TValue bptree = split_check_let_bindings(K, bindings, &exprs, false);
krooted_tvs_push(K, exprs);
krooted_tvs_push(K, bptree);
- UNUSED(check_list(K, name, true, body, NULL));
+ check_list(K, true, body, NULL, NULL);
- body = copy_es_immutable_h(K, name, body, false);
+ body = copy_es_immutable_h(K, body, false);
krooted_tvs_push(K, body);
/* according to the definition of the report it should be a child
@@ -657,7 +649,7 @@ void do_b_to_env(klisp_State *K)
TValue ptree = xparams[0];
TValue env = xparams[1];
- match(K, "$bindings->environment", env, ptree, obj);
+ match(K, env, ptree, obj);
kapply_cc(K, env);
}
@@ -670,8 +662,7 @@ void Sbindings_to_environment(klisp_State *K)
klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
TValue exprs;
- TValue bptree = split_check_let_bindings(K, "$bindings->environment",
- ptree, &exprs, false);
+ TValue bptree = split_check_let_bindings(K, ptree, &exprs, false);
krooted_tvs_push(K, exprs);
krooted_tvs_push(K, bptree);
diff --git a/src/kgenvironments.h b/src/kgenvironments.h
@@ -7,78 +7,7 @@
#ifndef kgenvironments_h
#define kgenvironments_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* 4.8.1 environment? */
-/* uses typep */
-
-/* 4.8.2 ignore? */
-/* uses typep */
-
-/* 4.8.3 eval */
-void eval(klisp_State *K);
-
-/* 4.8.4 make-environment */
-void make_environment(klisp_State *K);
-
-/* Helpers for all $let family */
-TValue split_check_let_bindings(klisp_State *K, char *name, TValue bindings,
- TValue *exprs, bool starp);
-/* 5.10.1 $let */
-void Slet(klisp_State *K);
-
-/* Helper for $binds? */
-void do_bindsp(klisp_State *K);
-
-/* 6.7.1 $binds? */
-void Sbindsp(klisp_State *K);
-
-/* 6.7.2 get-current-environment */
-void get_current_environment(klisp_State *K);
-
-/* 6.7.3 make-kernel-standard-environment */
-void make_kernel_standard_environment(klisp_State *K);
-
-/* 6.7.4 $let* */
-void SletS(klisp_State *K);
-
-/* 6.7.5 $letrec */
-void Sletrec(klisp_State *K);
-
-/* 6.7.6 $letrec* */
-void SletrecS(klisp_State *K);
-
-/* Helper for $let-redirect */
-void do_let_redirect(klisp_State *K);
-
-/* 6.7.7 $let-redirect */
-void Slet_redirect(klisp_State *K);
-
-/* 6.7.8 $let-safe */
-void Slet_safe(klisp_State *K);
-
-/* 6.7.9 $remote-eval */
-void Sremote_eval(klisp_State *K);
-
-/* Helper for $remote-eval */
-void do_remote_eval(klisp_State *K);
-
-/* Helper for $bindings->environment */
-void do_b_to_env(klisp_State *K);
-
-/* 6.7.10 $bindings->environment */
-void Sbindings_to_environment(klisp_State *K);
-
-void do_let(klisp_State *K);
/* init ground */
void kinit_environments_ground_env(klisp_State *K);
diff --git a/src/kgeqp.c b/src/kgeqp.c
@@ -31,7 +31,8 @@ void eqp(klisp_State *K)
UNUSED(denv);
UNUSED(xparams);
- int32_t pairs = check_list(K, "eq?", true, ptree, NULL);
+ int32_t pairs;
+ check_list(K, true, ptree, &pairs, NULL);
/* In this case we can get away without comparing the
first and last element on a cycle because eq? is
diff --git a/src/kgeqp.h b/src/kgeqp.h
@@ -7,59 +7,7 @@
#ifndef kgeqp_h
#define kgeqp_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
#include "kstate.h"
-#include "kobject.h"
-#include "kapplicative.h" /* for unwrap */
-#include "kinteger.h" /* for kbigint_eqp */
-#include "krational.h" /* for kbigrat_eqp */
-#include "klisp.h"
-#include "kghelpers.h"
-
-/* 4.2.1 eq? */
-/* 6.5.1 eq? */
-void eqp(klisp_State *K);
-
-/* Helper (also used in equal?) */
-inline bool eq2p(klisp_State *K, TValue obj1, TValue obj2)
-{
- bool res = (tv_equal(obj1, obj2));
- if (!res && (ttype(obj1) == ttype(obj2))) {
- switch (ttype(obj1)) {
- case K_TSYMBOL:
- /* symbols can't be compared with tv_equal! */
- res = tv_sym_equal(obj1, obj2);
- break;
- case K_TAPPLICATIVE:
- while(ttisapplicative(obj1) && ttisapplicative(obj2)) {
- obj1 = kunwrap(obj1);
- obj2 = kunwrap(obj2);
- }
- res = (tv_equal(obj1, obj2));
- break;
- case K_TBIGINT:
- /* it's important to know that it can't be the case
- that obj1 is bigint and obj is some other type and
- (eq? obj1 obj2) */
- res = kbigint_eqp(obj1, obj2);
- break;
- case K_TBIGRAT:
- /* it's important to know that it can't be the case
- that obj1 is bigrat and obj is some other type and
- (eq? obj1 obj2) */
- res = kbigrat_eqp(K, obj1, obj2);
- break;
- } /* immutable strings & bytevectors are interned so they are
- covered already by tv_equalp */
-
- }
- return res;
-}
/* init ground */
void kinit_eqp_ground_env(klisp_State *K);
diff --git a/src/kgequalp.c b/src/kgequalp.c
@@ -20,7 +20,6 @@
#include "kerror.h"
#include "kghelpers.h"
-#include "kgeqp.h" /* for eq2p */
#include "kgequalp.h"
/* 4.3.1 equal? */
@@ -44,7 +43,8 @@ void equalp(klisp_State *K)
UNUSED(denv);
UNUSED(xparams);
- int32_t pairs = check_list(K, "equal?", true, ptree, NULL);
+ int32_t pairs;
+ check_list(K, true, ptree, &pairs, NULL);
/* In this case we can get away without comparing the
first and last element on a cycle because equal? is
@@ -66,195 +66,6 @@ void equalp(klisp_State *K)
kapply_cc(K, res);
}
-
-/*
-** Helpers
-**
-** See [2] for details of the list merging algorithm.
-** Here are the implementation details:
-** The marks of the pairs are used to store the nodes of the trees
-** that represent the set of previous comparations of each pair.
-** They serve the function of the array in [2].
-** If a pair is unmarked, it was never compared (empty comparison set).
-** If a pair is marked, the mark object is either (#f . parent-node)
-** if the node is not the root, and (#t . n) where n is the number
-** of elements in the set, if the node is the root.
-** This pair also doubles as the "name" of the set in [2].
-**
-** GC: all of these assume that arguments are rooted.
-*/
-
-/* find "name" of the set of this obj, if there isn't one create it,
- if there is one, flatten its branch */
-inline TValue equal_find(klisp_State *K, TValue obj)
-{
- /* GC: should root obj */
- if (kis_unmarked(obj)) {
- /* object wasn't compared before, create new set */
- TValue new_node = kcons(K, KTRUE, i2tv(1));
- kset_mark(obj, new_node);
- return new_node;
- } else {
- TValue node = kget_mark(obj);
-
- /* First obtain the root and a list of all the other objects in this
- branch, as said above the root is the one with #t in its car */
- /* NOTE: the stack is being used, so we must remember how many pairs we
- push, we can't just pop 'till is empty */
- int np = 0;
- while(kis_false(kcar(node))) {
- ks_spush(K, node);
- node = kcdr(node);
- ++np;
- }
- TValue root = node;
-
- /* set all parents to root, to flatten the branch */
- while(np--) {
- node = ks_spop(K);
- kset_cdr(node, root);
- }
- return root;
- }
-}
-
-/* merge the smaller set into the big one, if both are equal just pick one */
-inline void equal_merge(klisp_State *K, TValue root1, TValue root2)
-{
- /* K isn't needed but added for consistency */
- UNUSED(K);
- int32_t size1 = ivalue(kcdr(root1));
- int32_t size2 = ivalue(kcdr(root2));
- TValue new_size = i2tv(size1 + size2);
-
- if (size1 < size2) {
- /* add root1 set (the smaller one) to root2 */
- kset_cdr(root2, new_size);
- kset_car(root1, KFALSE);
- kset_cdr(root1, root2);
- } else {
- /* add root2 set (the smaller one) to root1 */
- kset_cdr(root1, new_size);
- kset_car(root2, KFALSE);
- kset_cdr(root2, root1);
- }
-}
-
-/* check to see if two objects were already compared, and return that. If they
- weren't compared yet, merge their sets (and flatten their branches) */
-inline bool equal_find2_mergep(klisp_State *K, TValue obj1, TValue obj2)
-{
- /* GC: should root root1 and root2 */
- TValue root1 = equal_find(K, obj1);
- TValue root2 = equal_find(K, obj2);
- if (tv_equal(root1, root2)) {
- /* they are in the same set => they were already compared */
- return true;
- } else {
- equal_merge(K, root1, root2);
- return false;
- }
-}
-
-/*
-** See [1] for details, in this case the pairs form a possibly infinite "tree"
-** structure, and that can be seen as a finite automata, where each node is a
-** state, the car and the cdr are the transitions from that state to others,
-** and the leaves (the non-pair objects) are the final states.
-** Other way to see it is that, the key for determining equalness of two pairs
-** is: Check to see if they were already compared to each other.
-** If so, return #t, otherwise, mark them as compared to each other and
-** recurse on both cars and both cdrs.
-** The idea is that if assuming obj1 and obj2 are equal their components are
-** equal then they are effectively equal to each other.
-*/
-bool equal2p(klisp_State *K, TValue obj1, TValue obj2)
-{
- assert(ks_sisempty(K));
-
- /* the stack has the elements to be compaired, always in pairs.
- So the top should be compared with the one below, the third with
- the fourth and so on */
- ks_spush(K, obj1);
- ks_spush(K, obj2);
-
- /* if the stacks becomes empty, all pairs of elements were equal */
- bool result = true;
- TValue saved_obj1 = obj1;
- TValue saved_obj2 = obj2;
-
- while(!ks_sisempty(K)) {
- obj2 = ks_spop(K);
- obj1 = ks_spop(K);
-
- if (!eq2p(K, obj1, obj2)) {
- /* This type comparison works because we just care about
- pairs, vectors, strings & bytevectors */
- if (ttype(obj1) == ttype(obj2)) {
- switch(ttype(obj1)) {
- case K_TPAIR:
- /* if they were already compaired, consider equal for
- now otherwise they are equal if both their cars
- and cdrs are */
- if (!equal_find2_mergep(K, obj1, obj2)) {
- ks_spush(K, kcdr(obj1));
- ks_spush(K, kcdr(obj2));
- ks_spush(K, kcar(obj1));
- ks_spush(K, kcar(obj2));
- }
- break;
- case K_TVECTOR:
- if (kvector_size(obj1) == kvector_size(obj2)) {
- /* if they were already compaired, consider equal for
- now otherwise they are equal if all their elements
- are equal pairwise */
- if (!equal_find2_mergep(K, obj1, obj2)) {
- uint32_t i = kvector_size(obj1);
- TValue *array1 = kvector_buf(obj1);
- TValue *array2 = kvector_buf(obj1);
- while(i-- > 0) {
- ks_spush(K, array1[i]);
- ks_spush(K, array2[i]);
- }
- }
- } else {
- result = false;
- goto end;
- }
- break;
- case K_TSTRING:
- if (!kstring_equalp(obj1, obj2)) {
- result = false;
- goto end;
- }
- break;
- case K_TBYTEVECTOR:
- if (!kbytevector_equalp(obj1, obj2)) {
- result = false;
- goto end;
- }
- break;
- default:
- result = false;
- goto end;
- }
- } else {
- result = false;
- goto end;
- }
- }
- }
-end:
- /* if result is false, the stack may not be empty */
- ks_sclear(K);
-
- unmark_tree(K, saved_obj1);
- unmark_tree(K, saved_obj2);
-
- return result;
-}
-
-
/* init ground */
void kinit_equalp_ground_env(klisp_State *K)
{
diff --git a/src/kgequalp.h b/src/kgequalp.h
@@ -7,24 +7,7 @@
#ifndef kgequalp_h
#define kgequalp_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
#include "kstate.h"
-#include "kobject.h"
-#include "klisp.h"
-#include "kghelpers.h"
-
-/* 4.3.1 equal? */
-/* 6.6.1 equal? */
-void equalp(klisp_State *K);
-
-/* Helper (may be used in assoc and member) */
-/* compare two objects and check to see if they are "equal?". */
-bool equal2p(klisp_State *K, TValue obj1, TValue obj2);
/* init ground */
void kinit_equalp_ground_env(klisp_State *K);
diff --git a/src/kgerrors.c b/src/kgerrors.c
@@ -28,7 +28,7 @@ void kgerror(klisp_State *K)
bind_al1tp(K, ptree, "string", ttisstring, str, rest);
/* copy the list of irritants, to avoid modification later */
/* also check that is a list! */
- TValue irritants = check_copy_list(K, "error", rest, false);
+ TValue irritants = check_copy_list(K, rest, false, NULL, NULL);
krooted_tvs_push(K, irritants);
/* the msg is implicitly copied here */
klispE_throw_with_irritants(K, kstring_buf(str), irritants);
diff --git a/src/kgerrors.h b/src/kgerrors.h
@@ -7,16 +7,7 @@
#ifndef kgerrors_h
#define kgerrors_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
/* init ground */
void kinit_error_ground_env(klisp_State *K);
diff --git a/src/kgffi.c b/src/kgffi.c
@@ -41,9 +41,6 @@
#include "ktable.h"
#include "kghelpers.h"
-#include "kgencapsulations.h"
-#include "kgcombiners.h"
-#include "kgcontinuations.h"
#include "kgffi.h"
/* Set to 0 to ignore aligment errors during direct
@@ -482,8 +479,9 @@ void ffi_make_call_interface(klisp_State *K)
"argtypes string list", ttislist, argtypes_tv);
#undef ttislist
- size_t nargs = check_typed_list(K, "ffi-make-call-interface", "argtype string",
- kstringp, false, argtypes_tv, NULL);
+ size_t nargs;
+ check_typed_list(K, kstringp, false, argtypes_tv, (int32_t *) &nargs,
+ NULL);
/* Allocate C structure ffi_call_interface_t inside
a mutable bytevector. The structure contains C pointers
diff --git a/src/kgffi.h b/src/kgffi.h
@@ -10,18 +10,8 @@
#if (KUSE_LIBFFI != 1)
# error "Compiling FFI code, but KUSE_LIBFFI != 1."
#endif
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-void ffi_load_library(klisp_State *K);
/* init ground */
void kinit_ffi_ground_env(klisp_State *K);
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -4,7 +4,6 @@
** See Copyright Notice in klisp.h
*/
-#include <assert.h>
#include <stdlib.h>
#include <stdio.h>
#include <stdbool.h>
@@ -16,7 +15,130 @@
#include "klisp.h"
#include "kerror.h"
#include "ksymbol.h"
+#include "kenvironment.h"
#include "kinteger.h"
+#include "krational.h"
+#include "kapplicative.h"
+#include "kbytevector.h"
+#include "kvector.h"
+#include "kstring.h"
+#include "kpair.h"
+#include "kcontinuation.h"
+#include "kencapsulation.h"
+
+/* Type predicates */
+/* TODO these should be moved to either kobject.h or the corresponding
+ files (e.g. kbooleanp to kboolean.h */
+bool kbooleanp(TValue obj) { return ttisboolean(obj); }
+bool kcombinerp(TValue obj) { return ttiscombiner(obj); }
+bool knumberp(TValue obj) { return ttisnumber(obj); }
+/* TEMP used (as a type predicate) in all predicates that need a primary value
+ (XXX it's not actually a type error, but it's close enough and otherwise
+ should define new predp & bpredp for numeric predicates...) */
+bool knumber_wpvp(TValue obj)
+{
+ return ttisnumber(obj) && !ttisrwnpv(obj) && !ttisundef(obj);
+}
+/* This is used in gcd & lcm */
+bool kimp_intp(TValue obj) { return ttisinteger(obj) || ttisinf(obj); }
+/* obj is known to be a number */
+bool kfinitep(TValue obj) { return !ttisinf(obj); }
+/* fixint, bigints & inexact integers */
+bool kintegerp(TValue obj) { return ttisinteger(obj); }
+/* only exact integers (like for indices), bigints & fixints */
+bool keintegerp(TValue obj) { return ttiseinteger(obj); }
+/* exact integers between 0 and 255 inclusive */
+bool ku8p(TValue obj) { return ttisu8(obj); }
+bool krationalp(TValue obj) { return ttisrational(obj); }
+bool krealp(TValue obj) { return ttisreal(obj); }
+/* TEMP used (as a type predicate) in all predicates that need a real with
+ primary value (XXX it's not actually a type error, but it's close enough
+ and otherwise should define new predp & bpredp for numeric predicates...) */
+bool kreal_wpvp(TValue obj) { return ttisreal(obj) && !ttisrwnpv(obj); }
+
+bool kexactp(TValue obj) { return ttisexact(obj); }
+bool kinexactp(TValue obj) { return ttisinexact(obj); }
+bool kundefinedp(TValue obj) { return ttisundef(obj); }
+bool krobustp(TValue obj) { return ttisrobust(obj); }
+
+void enc_typep(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(denv);
+ /*
+ ** xparams[0]: encapsulation key
+ */
+ TValue key = xparams[0];
+
+ /* check the ptree is a list while checking the predicate.
+ Keep going even if the result is false to catch errors in
+ ptree structure */
+ bool res = true;
+
+ TValue tail = ptree;
+ while(ttispair(tail) && kis_unmarked(tail)) {
+ kmark(tail);
+ res &= kis_encapsulation_type(kcar(tail), key);
+ tail = kcdr(tail);
+ }
+ unmark_list(K, ptree);
+
+ if (ttispair(tail) || ttisnil(tail)) {
+ kapply_cc(K, b2tv(res));
+ } else {
+ /* try to get name from encapsulation */
+ klispE_throw_simple(K, "expected list");
+ return;
+ }
+}
+/* /Type predicates */
+
+/* some number functions */
+bool kpositivep(TValue n)
+{
+ switch (ttype(n)) {
+ case K_TFIXINT:
+ case K_TEINF:
+ case K_TIINF:
+ return ivalue(n) > 0;
+ case K_TBIGINT:
+ return kbigint_positivep(n);
+ case K_TBIGRAT:
+ return kbigrat_positivep(n);
+ case K_TDOUBLE:
+ return dvalue(n) > 0.0;
+ /* real with no prim value, complex and undefined should be captured by
+ type predicate */
+ default:
+ klisp_assert(0);
+ return false;
+ }
+}
+
+bool knegativep(TValue n)
+{
+ switch (ttype(n)) {
+ case K_TFIXINT:
+ case K_TEINF:
+ case K_TIINF:
+ return ivalue(n) < 0;
+ case K_TBIGINT:
+ return kbigint_negativep(n);
+ case K_TBIGRAT:
+ return kbigrat_negativep(n);
+ case K_TDOUBLE:
+ return dvalue(n) < 0.0;
+ /* real with no prim value, complex and undefined should be captured by
+ type predicate */
+ default:
+ klisp_assert(0);
+ return false;
+ }
+}
+/* /some number functions */
void typep(klisp_State *K)
{
@@ -101,14 +223,13 @@ void ftyped_predp(klisp_State *K)
** xparams[1]: type fn pointer (as a void * in a user TValue)
** xparams[2]: fn pointer (as a void * in a user TValue)
*/
- char *name = ksymbol_buf(xparams[0]);
bool (*typep)(TValue obj) = pvalue(xparams[1]);
bool (*predp)(TValue obj) = pvalue(xparams[2]);
/* check the ptree is a list first to allow the structure
errors to take precedence over the type errors. */
- int32_t cpairs;
- int32_t pairs = check_list(K, name, true, ptree, &cpairs);
+ int32_t pairs, cpairs;
+ check_list(K, true, ptree, &pairs, &cpairs);
TValue tail = ptree;
bool res = true;
@@ -145,14 +266,13 @@ void ftyped_bpredp(klisp_State *K)
** xparams[1]: type fn pointer (as a void * in a user TValue)
** xparams[2]: fn pointer (as a void * in a user TValue)
*/
- char *name = ksymbol_buf(xparams[0]);
bool (*typep)(TValue obj) = pvalue(xparams[1]);
bool (*predp)(TValue obj1, TValue obj2) = pvalue(xparams[2]);
/* check the ptree is a list first to allow the structure
errors to take precedence over the type errors. */
- int32_t cpairs;
- int32_t pairs = check_list(K, name, true, ptree, &cpairs);
+ int32_t pairs, cpairs;
+ check_list(K, true, ptree, &pairs, &cpairs);
/* cyclical list require an extra comparison of the last
& first element of the cycle */
@@ -205,15 +325,14 @@ void ftyped_kbpredp(klisp_State *K)
** xparams[1]: type fn pointer (as a void * in a user TValue)
** xparams[2]: fn pointer (as a void * in a user TValue)
*/
- char *name = ksymbol_buf(xparams[0]);
bool (*typep)(TValue obj) = pvalue(xparams[1]);
bool (*predp)(klisp_State *K, TValue obj1, TValue obj2) =
pvalue(xparams[2]);
/* check the ptree is a list first to allow the structure
errors to take precedence over the type errors. */
- int32_t cpairs;
- int32_t pairs = check_list(K, name, true, ptree, &cpairs);
+ int32_t pairs, cpairs;
+ check_list(K, true, ptree, &pairs, &cpairs);
/* cyclical list require an extra comparison of the last
& first element of the cycle */
@@ -253,86 +372,153 @@ void ftyped_kbpredp(klisp_State *K)
}
/* typed finite list. Structure error should be throw before type errors */
-int32_t check_typed_list(klisp_State *K, char *name, char *typename,
- bool (*typep)(TValue), bool allow_infp, TValue obj,
- int32_t *cpairs)
+void check_typed_list(klisp_State *K, bool (*typep)(TValue), bool allow_infp,
+ TValue obj, int32_t *pairs, int32_t *cpairs)
{
TValue tail = obj;
- int32_t pairs = 0;
+ int32_t p = 0;
bool type_errorp = false;
while(ttispair(tail) && !kis_marked(tail)) {
/* even if there is a type error continue checking the structure */
type_errorp |= !(*typep)(kcar(tail));
- kset_mark(tail, i2tv(pairs));
+ kset_mark(tail, i2tv(p));
tail = kcdr(tail);
- ++pairs;
+ ++p;
}
+ if (pairs != NULL) *pairs = p;
if (cpairs != NULL)
- *cpairs = ttispair(tail)? (pairs - ivalue(kget_mark(tail))) : 0;
+ *cpairs = ttispair(tail)? (p - ivalue(kget_mark(tail))) : 0;
unmark_list(K, obj);
if (!ttispair(tail) && !ttisnil(tail)) {
klispE_throw_simple(K, allow_infp? "expected list" :
"expected finite list");
- return 0;
+ return;
} else if(ttispair(tail) && !allow_infp) {
klispE_throw_simple(K, "expected finite list");
- return 0;
+ return;
} else if (type_errorp) {
- /* TODO put type name too */
+ /* TODO put type name too, should be extracted from a
+ table of type names */
klispE_throw_simple(K, "bad operand type");
- return 0;
+ return;
}
- return pairs;
}
-int32_t check_list(klisp_State *K, const char *name, bool allow_infp,
- TValue obj, int32_t *cpairs)
+void check_list(klisp_State *K, bool allow_infp, TValue obj,
+ int32_t *pairs, int32_t *cpairs)
{
TValue tail = obj;
- int pairs = 0;
+ int32_t p = 0;
+
while(ttispair(tail) && !kis_marked(tail)) {
- kset_mark(tail, i2tv(pairs));
+ kset_mark(tail, i2tv(p));
tail = kcdr(tail);
- ++pairs;
+ ++p;
}
+ if (pairs != NULL) *pairs = p;
if (cpairs != NULL)
- *cpairs = ttispair(tail)? (pairs - ivalue(kget_mark(tail))) : 0;
+ *cpairs = ttispair(tail)? (p - ivalue(kget_mark(tail))) : 0;
unmark_list(K, obj);
if (!ttispair(tail) && !ttisnil(tail)) {
klispE_throw_simple(K, allow_infp? "expected list" :
"expected finite list");
- return 0;
+ return;
} else if(ttispair(tail) && !allow_infp) {
klispE_throw_simple(K, "expected finite list");
- return 0;
- } else {
- return pairs;
+ return;
}
}
-/*
-** Continuation that ignores the value received and instead returns
-** a previously computed value.
-*/
-void do_return_value(klisp_State *K)
+TValue check_copy_list(klisp_State *K, TValue obj, bool force_copy,
+ int32_t *pairs, int32_t *cpairs)
{
- TValue *xparams = K->next_xparams;
- TValue obj = K->next_value;
- klisp_assert(ttisnil(K->next_env));
- /*
- ** xparams[0]: saved_obj
- */
- UNUSED(obj);
- TValue ret_obj = xparams[0];
- kapply_cc(K, ret_obj);
+ int32_t p = 0;
+ if (ttisnil(obj)) {
+ if (pairs != NULL) *pairs = 0;
+ if (cpairs != NULL) *cpairs = 0;
+ return obj;
+ }
+
+ if (ttispair(obj) && kis_immutable(obj) && !force_copy) {
+ /* this will properly set pairs and cpairs */
+ check_list(K, true, obj, pairs, cpairs);
+ return obj;
+ } else {
+ TValue last_pair = kget_dummy3(K);
+ TValue tail = obj;
+
+ while(ttispair(tail) && !kis_marked(tail)) {
+ TValue new_pair = kcons(K, kcar(tail), KNIL);
+ /* record the corresponding pair to simplify cycle handling */
+ kset_mark(tail, new_pair);
+ /* record the pair number in the new pair, to set cpairs */
+ kset_mark(new_pair, i2tv(p));
+ /* copy the source code info */
+ TValue si = ktry_get_si(K, tail);
+ if (!ttisnil(si))
+ kset_source_info(K, new_pair, si);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ tail = kcdr(tail);
+ ++p;
+ }
+
+ if (pairs != NULL) *pairs = p;
+ if (cpairs != NULL)
+ *cpairs = ttispair(tail)?
+ (p - ivalue(kget_mark(kget_mark(tail)))) :
+ 0;
+
+ if (ttispair(tail)) {
+ /* complete the cycle */
+ kset_cdr(last_pair, kget_mark(tail));
+ }
+
+ unmark_list(K, obj);
+ unmark_list(K, kget_dummy3_tail(K));
+
+ if (!ttispair(tail) && !ttisnil(tail)) {
+ klispE_throw_simple(K, "expected list");
+ return KINERT;
+ }
+ return kcutoff_dummy3(K);
+ }
+}
+
+TValue check_copy_env_list(klisp_State *K, TValue obj)
+{
+ TValue last_pair = kget_dummy3(K);
+ TValue tail = obj;
+
+ while(ttispair(tail) && !kis_marked(tail)) {
+ TValue first = kcar(tail);
+ if (!ttisenvironment(first)) {
+ klispE_throw_simple(K, "not an environment in parent list");
+ return KINERT;
+ }
+ TValue new_pair = kcons(K, first, KNIL);
+ kmark(tail);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ tail = kcdr(tail);
+ }
+
+ /* even if there was a cycle, the copy ends with nil */
+ unmark_list(K, obj);
+
+ if (!ttispair(tail) && !ttisnil(tail)) {
+ klispE_throw_simple(K, "expected list");
+ return KINERT;
+ }
+ return kcutoff_dummy3(K);
}
/* Some helpers for working with fixints (signed 32 bits) */
@@ -385,6 +571,20 @@ int64_t klcm32_64(int32_t a_, int32_t b_)
return (a / gcd) * b;
}
+/* list applicative (used in kstate and kgpairs_lists) */
+void list(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+/* the underlying combiner of list return the complete ptree, the only list
+ checking is implicit in the applicative evaluation */
+ UNUSED(xparams);
+ UNUSED(denv);
+ kapply_cc(K, ptree);
+}
+
/* Helper for get-list-metrics, and list-tail, list-ref and list-set!
when receiving bigint indexes */
void get_list_metrics_aux(klisp_State *K, TValue obj, int32_t *p, int32_t *n,
@@ -430,8 +630,7 @@ void get_list_metrics_aux(klisp_State *K, TValue obj, int32_t *p, int32_t *n,
tk is a bigint and all lists have fixint range number of pairs,
so the list should cyclic and we should calculate an index that
doesn't go through the complete cycle not even once */
-int32_t ksmallest_index(klisp_State *K, char *name, TValue obj,
- TValue tk)
+int32_t ksmallest_index(klisp_State *K, TValue obj, TValue tk)
{
int32_t apairs, cpairs;
get_list_metrics_aux(K, obj, NULL, NULL, &apairs, &cpairs);
@@ -457,3 +656,1054 @@ int32_t ksmallest_index(klisp_State *K, char *name, TValue obj,
assert(ttisfixint(idx));
return ivalue(idx) + apairs;
}
+
+/* Helper for eq? and equal? */
+bool eq2p(klisp_State *K, TValue obj1, TValue obj2)
+{
+ bool res = (tv_equal(obj1, obj2));
+ if (!res && (ttype(obj1) == ttype(obj2))) {
+ switch (ttype(obj1)) {
+ case K_TSYMBOL:
+ /* symbols can't be compared with tv_equal! */
+ res = tv_sym_equal(obj1, obj2);
+ break;
+ case K_TAPPLICATIVE:
+ while(ttisapplicative(obj1) && ttisapplicative(obj2)) {
+ obj1 = kunwrap(obj1);
+ obj2 = kunwrap(obj2);
+ }
+ res = (tv_equal(obj1, obj2));
+ break;
+ case K_TBIGINT:
+ /* it's important to know that it can't be the case
+ that obj1 is bigint and obj is some other type and
+ (eq? obj1 obj2) */
+ res = kbigint_eqp(obj1, obj2);
+ break;
+ case K_TBIGRAT:
+ /* it's important to know that it can't be the case
+ that obj1 is bigrat and obj is some other type and
+ (eq? obj1 obj2) */
+ res = kbigrat_eqp(K, obj1, obj2);
+ break;
+ } /* immutable strings & bytevectors are interned so they are
+ covered already by tv_equalp */
+
+ }
+ return res;
+}
+
+/*
+** Helpers for equal? algorithm
+**
+** See [2] for details of the list merging algorithm.
+** Here are the implementation details:
+** The marks of the pairs are used to store the nodes of the trees
+** that represent the set of previous comparations of each pair.
+** They serve the function of the array in [2].
+** If a pair is unmarked, it was never compared (empty comparison set).
+** If a pair is marked, the mark object is either (#f . parent-node)
+** if the node is not the root, and (#t . n) where n is the number
+** of elements in the set, if the node is the root.
+** This pair also doubles as the "name" of the set in [2].
+**
+** GC: all of these assume that arguments are rooted.
+*/
+
+/* find "name" of the set of this obj, if there isn't one create it,
+ if there is one, flatten its branch */
+inline TValue equal_find(klisp_State *K, TValue obj)
+{
+ /* GC: should root obj */
+ if (kis_unmarked(obj)) {
+ /* object wasn't compared before, create new set */
+ TValue new_node = kcons(K, KTRUE, i2tv(1));
+ kset_mark(obj, new_node);
+ return new_node;
+ } else {
+ TValue node = kget_mark(obj);
+
+ /* First obtain the root and a list of all the other objects in this
+ branch, as said above the root is the one with #t in its car */
+ /* NOTE: the stack is being used, so we must remember how many pairs we
+ push, we can't just pop 'till is empty */
+ int np = 0;
+ while(kis_false(kcar(node))) {
+ ks_spush(K, node);
+ node = kcdr(node);
+ ++np;
+ }
+ TValue root = node;
+
+ /* set all parents to root, to flatten the branch */
+ while(np--) {
+ node = ks_spop(K);
+ kset_cdr(node, root);
+ }
+ return root;
+ }
+}
+
+/* merge the smaller set into the big one, if both are equal just pick one */
+inline void equal_merge(klisp_State *K, TValue root1, TValue root2)
+{
+ /* K isn't needed but added for consistency */
+ UNUSED(K);
+ int32_t size1 = ivalue(kcdr(root1));
+ int32_t size2 = ivalue(kcdr(root2));
+ TValue new_size = i2tv(size1 + size2);
+
+ if (size1 < size2) {
+ /* add root1 set (the smaller one) to root2 */
+ kset_cdr(root2, new_size);
+ kset_car(root1, KFALSE);
+ kset_cdr(root1, root2);
+ } else {
+ /* add root2 set (the smaller one) to root1 */
+ kset_cdr(root1, new_size);
+ kset_car(root2, KFALSE);
+ kset_cdr(root2, root1);
+ }
+}
+
+/* check to see if two objects were already compared, and return that. If they
+ weren't compared yet, merge their sets (and flatten their branches) */
+inline bool equal_find2_mergep(klisp_State *K, TValue obj1, TValue obj2)
+{
+ /* GC: should root root1 and root2 */
+ TValue root1 = equal_find(K, obj1);
+ TValue root2 = equal_find(K, obj2);
+ if (tv_equal(root1, root2)) {
+ /* they are in the same set => they were already compared */
+ return true;
+ } else {
+ equal_merge(K, root1, root2);
+ return false;
+ }
+}
+
+/*
+** See [1] for details, in this case the pairs form a possibly infinite "tree"
+** structure, and that can be seen as a finite automata, where each node is a
+** state, the car and the cdr are the transitions from that state to others,
+** and the leaves (the non-pair objects) are the final states.
+** Other way to see it is that, the key for determining equalness of two pairs
+** is: Check to see if they were already compared to each other.
+** If so, return #t, otherwise, mark them as compared to each other and
+** recurse on both cars and both cdrs.
+** The idea is that if assuming obj1 and obj2 are equal their components are
+** equal then they are effectively equal to each other.
+*/
+bool equal2p(klisp_State *K, TValue obj1, TValue obj2)
+{
+ assert(ks_sisempty(K));
+
+ /* the stack has the elements to be compaired, always in pairs.
+ So the top should be compared with the one below, the third with
+ the fourth and so on */
+ ks_spush(K, obj1);
+ ks_spush(K, obj2);
+
+ /* if the stacks becomes empty, all pairs of elements were equal */
+ bool result = true;
+ TValue saved_obj1 = obj1;
+ TValue saved_obj2 = obj2;
+
+ while(!ks_sisempty(K)) {
+ obj2 = ks_spop(K);
+ obj1 = ks_spop(K);
+
+ if (!eq2p(K, obj1, obj2)) {
+ /* This type comparison works because we just care about
+ pairs, vectors, strings & bytevectors */
+ if (ttype(obj1) == ttype(obj2)) {
+ switch(ttype(obj1)) {
+ case K_TPAIR:
+ /* if they were already compaired, consider equal for
+ now otherwise they are equal if both their cars
+ and cdrs are */
+ if (!equal_find2_mergep(K, obj1, obj2)) {
+ ks_spush(K, kcdr(obj1));
+ ks_spush(K, kcdr(obj2));
+ ks_spush(K, kcar(obj1));
+ ks_spush(K, kcar(obj2));
+ }
+ break;
+ case K_TVECTOR:
+ if (kvector_size(obj1) == kvector_size(obj2)) {
+ /* if they were already compaired, consider equal for
+ now otherwise they are equal if all their elements
+ are equal pairwise */
+ if (!equal_find2_mergep(K, obj1, obj2)) {
+ uint32_t i = kvector_size(obj1);
+ TValue *array1 = kvector_buf(obj1);
+ TValue *array2 = kvector_buf(obj1);
+ while(i-- > 0) {
+ ks_spush(K, array1[i]);
+ ks_spush(K, array2[i]);
+ }
+ }
+ } else {
+ result = false;
+ goto end;
+ }
+ break;
+ case K_TSTRING:
+ if (!kstring_equalp(obj1, obj2)) {
+ result = false;
+ goto end;
+ }
+ break;
+ case K_TBYTEVECTOR:
+ if (!kbytevector_equalp(obj1, obj2)) {
+ result = false;
+ goto end;
+ }
+ break;
+ default:
+ result = false;
+ goto end;
+ }
+ } else {
+ result = false;
+ goto end;
+ }
+ }
+ }
+end:
+ /* if result is false, the stack may not be empty */
+ ks_sclear(K);
+
+ unmark_tree(K, saved_obj1);
+ unmark_tree(K, saved_obj2);
+
+ return result;
+}
+
+/*
+** This is in a helper method to use it from $lambda, $vau, etc
+**
+** We mark each seen mutable pair with the corresponding copied
+** immutable pair to construct a structure that is isomorphic to
+** the original.
+** All objects that aren't mutable pairs are retained without
+** copying
+** sstack is used to keep track of pairs and tbstack is used
+** to keep track of which of car or cdr we were copying,
+** 0 means just pushed, 1 means return from car, 2 means return from cdr
+**
+** This also copies source code info
+**
+*/
+
+/* GC: assumes obj is rooted */
+TValue copy_es_immutable_h(klisp_State *K, TValue obj, bool mut_flag)
+{
+ TValue copy = obj;
+ krooted_vars_push(K, ©);
+
+ assert(ks_sisempty(K));
+ assert(ks_tbisempty(K));
+
+ ks_spush(K, obj);
+ ks_tbpush(K, ST_PUSH);
+
+ while(!ks_sisempty(K)) {
+ char state = ks_tbpop(K);
+ TValue top = ks_spop(K);
+
+ if (state == ST_PUSH) {
+ /* if the pair is immutable & we are constructing immutable
+ pairs there is no need to copy */
+ if (ttispair(top) && (mut_flag || kis_mutable(top))) {
+ if (kis_marked(top)) {
+ /* this pair was already seen, use the same */
+ copy = kget_mark(top);
+ } else {
+ TValue new_pair = kcons_g(K, mut_flag, KINERT, KINERT);
+ kset_mark(top, new_pair);
+ /* save the source code info on the new pair */
+ /* MAYBE: only do it if mutable */
+ TValue si = ktry_get_si(K, top);
+ if (!ttisnil(si))
+ kset_source_info(K, new_pair, si);
+ /* leave the pair in the stack, continue with the car */
+ ks_spush(K, top);
+ ks_tbpush(K, ST_CAR);
+
+ ks_spush(K, kcar(top));
+ ks_tbpush(K, ST_PUSH);
+ }
+ } else {
+ copy = top;
+ }
+ } else { /* last action was a pop */
+ TValue new_pair = kget_mark(top);
+ if (state == ST_CAR) {
+ /* new_pair may be immutable */
+ kset_car_unsafe(K, new_pair, copy);
+ /* leave the pair on the stack, continue with the cdr */
+ ks_spush(K, top);
+ ks_tbpush(K, ST_CDR);
+
+ ks_spush(K, kcdr(top));
+ ks_tbpush(K, ST_PUSH);
+ } else {
+ /* new_pair may be immutable */
+ kset_cdr_unsafe(K, new_pair, copy);
+ copy = new_pair;
+ }
+ }
+ }
+ unmark_tree(K, obj);
+ krooted_vars_pop(K);
+ return copy;
+}
+
+/* ptree handling */
+
+/*
+** Clear all the marks (symbols + pairs) & stacks.
+** The stack should contain only pairs, sym_ls should be
+** as above
+*/
+inline void ptree_clear_all(klisp_State *K, TValue sym_ls)
+{
+ while(!ttisnil(sym_ls)) {
+ TValue first = sym_ls;
+ sym_ls = kget_symbol_mark(first);
+ kunmark_symbol(first);
+ }
+
+ while(!ks_sisempty(K)) {
+ kunmark(ks_sget(K));
+ ks_sdpop(K);
+ }
+
+ ks_tbclear(K);
+}
+
+/* GC: assumes env, ptree & obj are rooted */
+void match(klisp_State *K, TValue env, TValue ptree, TValue obj)
+{
+ assert(ks_sisempty(K));
+ ks_spush(K, obj);
+ ks_spush(K, ptree);
+
+ while(!ks_sisempty(K)) {
+ ptree = ks_spop(K);
+ obj = ks_spop(K);
+
+ switch(ttype(ptree)) {
+ case K_TNIL:
+ if (!ttisnil(obj)) {
+ /* TODO show ptree and arguments */
+ ks_sclear(K);
+ klispE_throw_simple(K, "ptree doesn't match arguments");
+ return;
+ }
+ break;
+ case K_TIGNORE:
+ /* do nothing */
+ break;
+ case K_TSYMBOL:
+ kadd_binding(K, env, ptree, obj);
+ break;
+ case K_TPAIR:
+ if (ttispair(obj)) {
+ ks_spush(K, kcdr(obj));
+ ks_spush(K, kcdr(ptree));
+ ks_spush(K, kcar(obj));
+ ks_spush(K, kcar(ptree));
+ } else {
+ /* TODO show ptree and arguments */
+ ks_sclear(K);
+ klispE_throw_simple(K, "ptree doesn't match arguments");
+ return;
+ }
+ break;
+ default:
+ /* can't really happen */
+ break;
+ }
+ }
+}
+
+/* GC: assumes ptree & penv are rooted */
+TValue check_copy_ptree(klisp_State *K, TValue ptree, TValue penv)
+{
+ /* copy is only valid if the state isn't ST_PUSH */
+ /* but init anyways for gc (and avoiding warnings) */
+ TValue copy = ptree;
+ krooted_vars_push(K, ©);
+
+ /*
+ ** NIL terminated singly linked list of symbols
+ ** (using the mark as next pointer)
+ */
+ TValue sym_ls = KNIL;
+
+ assert(ks_sisempty(K));
+ assert(ks_tbisempty(K));
+
+ ks_tbpush(K, ST_PUSH);
+ ks_spush(K, ptree);
+
+ while(!ks_sisempty(K)) {
+ char state = ks_tbpop(K);
+ TValue top = ks_spop(K);
+
+ if (state == ST_PUSH) {
+ switch(ttype(top)) {
+ case K_TIGNORE:
+ case K_TNIL:
+ copy = top;
+ break;
+ case K_TSYMBOL: {
+ if (kis_symbol_marked(top)) {
+ ptree_clear_all(K, sym_ls);
+ klispE_throw_simple_with_irritants(K, "repeated symbol "
+ "in ptree", 1, top);
+ return KNIL;
+ } else {
+ copy = top;
+ /* add it to the symbol list */
+ kset_symbol_mark(top, sym_ls);
+ sym_ls = top;
+ }
+ break;
+ }
+ case K_TPAIR: {
+ if (kis_unmarked(top)) {
+ if (kis_immutable(top)) {
+ /* don't copy mutable pairs, just use them */
+ /* NOTE: immutable pairs can't have mutable
+ car or cdr */
+ /* we have to continue thou, because there could be a
+ cycle */
+ kset_mark(top, top);
+ } else {
+ /* create a new pair as copy, save it in the mark */
+ TValue new_pair = kimm_cons(K, KNIL, KNIL);
+ kset_mark(top, new_pair);
+ /* copy the source code info */
+ TValue si = ktry_get_si(K, top);
+ if (!ttisnil(si))
+ kset_source_info(K, new_pair, si);
+ }
+ /* keep the old pair and continue with the car */
+ ks_tbpush(K, ST_CAR);
+ ks_spush(K, top);
+
+ ks_tbpush(K, ST_PUSH);
+ ks_spush(K, kcar(top));
+ } else {
+ /* marked pair means a cycle was found */
+ /* NOTE: the pair should be in the stack already so
+ it isn't necessary to push it again to clear the mark */
+ ptree_clear_all(K, sym_ls);
+ klispE_throw_simple(K, "cycle detected in ptree");
+ /* avoid warning */
+ return KNIL;
+ }
+ break;
+ }
+ default:
+ ptree_clear_all(K, sym_ls);
+ klispE_throw_simple(K, "bad object type in ptree");
+ /* avoid warning */
+ return KNIL;
+ }
+ } else {
+ /* last operation was a pop */
+ /* top is a marked pair, the mark is the copied obj */
+ /* NOTE: if top is immutable the mark is also top
+ we could still do the set-car/set-cdr because the
+ copy would be the same as the car/cdr, but why bother */
+ if (state == ST_CAR) {
+ /* only car was checked (not yet copied) */
+ if (kis_mutable(top)) {
+ TValue copied_pair = kget_mark(top);
+ /* copied_pair may be immutable */
+ kset_car_unsafe(K, copied_pair, copy);
+ }
+ /* put the copied pair again, continue with the cdr */
+ ks_tbpush(K, ST_CDR);
+ ks_spush(K, top);
+
+ ks_tbpush(K, ST_PUSH);
+ ks_spush(K, kcdr(top));
+ } else {
+ /* both car & cdr were checked (cdr not yet copied) */
+ TValue copied_pair = kget_mark(top);
+ /* the unmark is needed to allow diamonds */
+ kunmark(top);
+
+ if (kis_mutable(top)) {
+ /* copied_pair may be immutable */
+ kset_cdr_unsafe(K, copied_pair, copy);
+ }
+ copy = copied_pair;
+ }
+ }
+ }
+
+ if (ttissymbol(penv)) {
+ if (kis_symbol_marked(penv)) {
+ ptree_clear_all(K, sym_ls);
+ klispE_throw_simple_with_irritants(K, "same symbol in both ptree "
+ "and environment parameter",
+ 1, sym_ls);
+ }
+ } else if (!ttisignore(penv)) {
+ ptree_clear_all(K, sym_ls);
+ klispE_throw_simple(K, "symbol or #ignore expected as "
+ "environment parmameter");
+ }
+ ptree_clear_all(K, sym_ls);
+ krooted_vars_pop(K);
+ return copy;
+}
+
+/* Helpers for map (also used by for each) */
+void map_for_each_get_metrics(klisp_State *K, TValue lss,
+ int32_t *app_apairs_out, int32_t *app_cpairs_out,
+ int32_t *res_apairs_out, int32_t *res_cpairs_out)
+{
+ /* avoid warnings (shouldn't happen if _No_return was used in throw) */
+ *app_apairs_out = 0;
+ *app_cpairs_out = 0;
+ *res_apairs_out = 0;
+ *res_cpairs_out = 0;
+
+ /* get the metrics of the ptree of each call to app */
+ int32_t app_pairs, app_cpairs;
+ check_list(K, true, lss, &app_pairs, &app_cpairs);
+ int32_t app_apairs = app_pairs - app_cpairs;
+
+ /* get the metrics of the result list */
+ int32_t res_pairs, res_cpairs;
+ /* We now that lss has at least one elem */
+ check_list(K, true, kcar(lss), &res_pairs, &res_cpairs);
+ int32_t res_apairs = res_pairs - res_cpairs;
+
+ if (res_cpairs == 0) {
+ /* finite list of length res_pairs (all lists should
+ have the same structure: acyclic with same length) */
+ int32_t pairs = app_pairs - 1;
+ TValue tail = kcdr(lss);
+ while(pairs--) {
+ int32_t first_pairs, first_cpairs;
+ check_list(K, true, kcar(tail), &first_pairs, &first_cpairs);
+ tail = kcdr(tail);
+
+ if (first_cpairs != 0) {
+ klispE_throw_simple(K, "mixed finite and infinite lists");
+ return;
+ } else if (first_pairs != res_pairs) {
+ klispE_throw_simple(K, "lists of different length");
+ return;
+ }
+ }
+ } else {
+ /* cyclic list: all lists should be cyclic.
+ result will have acyclic length equal to the
+ max of all the lists and cyclic length equal to the lcm
+ of all the lists. res_pairs may be broken but will be
+ restored by after the loop */
+ int32_t pairs = app_pairs - 1;
+ TValue tail = kcdr(lss);
+ while(pairs--) {
+ int32_t first_pairs, first_cpairs;
+ check_list(K, true, kcar(tail), &first_pairs, &first_cpairs);
+ int32_t first_apairs = first_pairs - first_cpairs;
+ tail = kcdr(tail);
+
+ if (first_cpairs == 0) {
+ klispE_throw_simple(K, "mixed finite and infinite lists");
+ return;
+ }
+ res_apairs = kmax32(res_apairs, first_apairs);
+ /* this can throw an error if res_cpairs doesn't
+ fit in 32 bits, which is a reasonable implementation
+ restriction because the list wouldn't fit in memory
+ anyways */
+ res_cpairs = kcheck32(K, "map/for-each: result list is too big",
+ klcm32_64(res_cpairs, first_cpairs));
+ }
+ res_pairs = kcheck32(K, "map/for-each: result list is too big",
+ (int64_t) res_cpairs + (int64_t) res_apairs);
+ UNUSED(res_pairs);
+ }
+
+ *app_apairs_out = app_apairs;
+ *app_cpairs_out = app_cpairs;
+ *res_apairs_out = res_apairs;
+ *res_cpairs_out = res_cpairs;
+}
+
+/* Return two lists, isomorphic to lss: one list of cars and one list
+ of cdrs (replacing the value of lss) */
+
+/* GC: assumes lss is rooted, and dummy1 & 2 are free in K */
+TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss,
+ int32_t apairs, int32_t cpairs)
+{
+ TValue tail = *lss;
+
+ TValue lp_cars = kget_dummy1(K);
+ TValue lap_cars = lp_cars;
+
+ TValue lp_cdrs = kget_dummy2(K);
+ TValue lap_cdrs = lp_cdrs;
+
+ while(apairs != 0 || cpairs != 0) {
+ int32_t pairs;
+ if (apairs != 0) {
+ pairs = apairs;
+ } else {
+ /* remember last acyclic pair of both lists to to encycle! later */
+ lap_cars = lp_cars;
+ lap_cdrs = lp_cdrs;
+ pairs = cpairs;
+ }
+
+ while(pairs--) {
+ TValue first = kcar(tail);
+ tail = kcdr(tail);
+
+ /* accumulate both cars and cdrs */
+ TValue np;
+ np = kcons(K, kcar(first), KNIL);
+ kset_cdr(lp_cars, np);
+ lp_cars = np;
+
+ np = kcons(K, kcdr(first), KNIL);
+ kset_cdr(lp_cdrs, np);
+ lp_cdrs = np;
+ }
+
+ if (apairs != 0) {
+ apairs = 0;
+ } else {
+ cpairs = 0;
+ /* encycle! the list of cars and the list of cdrs */
+ TValue fcp, lcp;
+ fcp = kcdr(lap_cars);
+ lcp = lp_cars;
+ kset_cdr(lcp, fcp);
+
+ fcp = kcdr(lap_cdrs);
+ lcp = lp_cdrs;
+ kset_cdr(lcp, fcp);
+ }
+ }
+
+ *lss = kcutoff_dummy2(K);
+ return kcutoff_dummy1(K);
+}
+
+/* Transpose lss so that the result is a list of lists, each one having
+ metrics (app_apairs, app_cpairs). The metrics of the returned list
+ should be (res_apairs, res_cpairs) */
+
+/* GC: assumes lss is rooted */
+TValue map_for_each_transpose(klisp_State *K, TValue lss,
+ int32_t app_apairs, int32_t app_cpairs,
+ int32_t res_apairs, int32_t res_cpairs)
+{
+ /* reserve dummy1 & 2 to get_cars_cdrs */
+ TValue lp = kget_dummy3(K);
+ TValue lap = lp;
+
+ TValue cars = KNIL; /* put something for GC */
+ TValue tail = lss;
+
+ /* GC: both cars & tail vary in each loop, to protect them we need
+ the vars stack */
+ krooted_vars_push(K, &cars);
+ krooted_vars_push(K, &tail);
+
+ /* Loop over list of lists, creating a list of cars and
+ a list of cdrs, accumulate the list of cars and loop
+ with the list of cdrs as the new list of lists (lss) */
+ while(res_apairs != 0 || res_cpairs != 0) {
+ int32_t pairs;
+
+ if (res_apairs != 0) {
+ pairs = res_apairs;
+ } else {
+ pairs = res_cpairs;
+ /* remember last acyclic pair to encycle! later */
+ lap = lp;
+ }
+
+ while(pairs--) {
+ /* accumulate cars and replace tail with cdrs */
+ cars = map_for_each_get_cars_cdrs(K, &tail, app_apairs, app_cpairs);
+ TValue np = kcons(K, cars, KNIL);
+ kset_cdr(lp, np);
+ lp = np;
+ }
+
+ if (res_apairs != 0) {
+ res_apairs = 0;
+ } else {
+ res_cpairs = 0;
+ /* encycle! the list of list of cars */
+ TValue fcp = kcdr(lap);
+ TValue lcp = lp;
+ kset_cdr(lcp, fcp);
+ }
+ }
+
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ return kcutoff_dummy3(K);
+}
+
+/* Continuations that are used in more than one file */
+
+/* Helper for $sequence, $vau, $lambda, ... */
+/* the remaining list can't be null, that case is managed before */
+void do_seq(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+
+ UNUSED(obj);
+
+ /*
+ ** xparams[0]: remaining list
+ ** xparams[1]: dynamic environment
+ */
+ TValue ls = xparams[0];
+ TValue first = kcar(ls);
+ TValue tail = kcdr(ls);
+ TValue denv = xparams[1];
+
+ if (ttispair(tail)) {
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2, tail,
+ denv);
+ kset_cc(K, new_cont);
+#if KTRACK_SI
+ /* put the source info of the list including the element
+ that we are about to evaluate */
+ kset_source_info(K, new_cont, ktry_get_si(K, ls));
+#endif
+ }
+ ktail_eval(K, first, denv);
+}
+
+/* this is used for inner & outer continuations, it just
+ passes the value. xparams is not actually empty, it contains
+ the entry/exit guards, but they are used only in
+ continuation->applicative (that is during abnormal passes) */
+void do_pass_value(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ UNUSED(xparams);
+ kapply_cc(K, obj);
+}
+
+/*
+** Continuation that ignores the value received and instead returns
+** a previously computed value.
+*/
+void do_return_value(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ /*
+ ** xparams[0]: saved_obj
+ */
+ UNUSED(obj);
+ TValue ret_obj = xparams[0];
+ kapply_cc(K, ret_obj);
+}
+
+/* binder returned */
+void do_bind(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ /*
+ ** xparams[0]: dynamic key
+ */
+ bind_2tp(K, ptree, "any", anytype, obj,
+ "combiner", ttiscombiner, comb);
+ UNUSED(denv); /* the combiner is called in an empty environment */
+ TValue key = xparams[0];
+ /* GC: root intermediate objs */
+ TValue new_flag = KTRUE;
+ TValue new_value = obj;
+ TValue old_flag = kcar(key);
+ TValue old_value = kcdr(key);
+ /* set the var to the new object */
+ kset_car(key, new_flag);
+ kset_cdr(key, new_value);
+ /* Old value must be protected from GC. It is no longer
+ reachable through key and not yet reachable through
+ continuation xparams. Boolean flag needn't be rooted,
+ because is not heap-allocated. */
+ krooted_tvs_push(K, old_value);
+ /* create a continuation to set the var to the correct value/flag on both
+ normal return and abnormal passes */
+ TValue new_cont = make_bind_continuation(K, key, old_flag, old_value,
+ new_flag, new_value);
+ krooted_tvs_pop(K);
+ kset_cc(K, new_cont); /* implicit rooting */
+ TValue env = kmake_empty_environment(K);
+ krooted_tvs_push(K, env);
+ TValue expr = kcons(K, comb, KNIL);
+ krooted_tvs_pop(K);
+ ktail_eval(K, expr, env)
+}
+
+/* accesor returned */
+void do_access(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ /*
+ ** xparams[0]: dynamic key
+ */
+ check_0p(K, ptree);
+ UNUSED(denv);
+ TValue key = xparams[0];
+
+ if (kis_true(kcar(key))) {
+ kapply_cc(K, kcdr(key));
+ } else {
+ klispE_throw_simple(K, "variable is unbound");
+ return;
+ }
+}
+
+/* continuation to set the key to the old value on normal return */
+void do_unbind(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue obj = K->next_value;
+ klisp_assert(ttisnil(K->next_env));
+ /*
+ ** xparams[0]: dynamic key
+ ** xparams[1]: old flag
+ ** xparams[2]: old value
+ */
+
+ TValue key = xparams[0];
+ TValue old_flag = xparams[1];
+ TValue old_value = xparams[2];
+
+ kset_car(key, old_flag);
+ kset_cdr(key, old_value);
+ /* pass along the value returned to this continuation */
+ kapply_cc(K, obj);
+}
+
+/* operative for setting the key to the new/old flag/value */
+void do_set_pass(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+ /*
+ ** xparams[0]: dynamic key
+ ** xparams[1]: flag
+ ** xparams[2]: value
+ */
+ TValue key = xparams[0];
+ TValue flag = xparams[1];
+ TValue value = xparams[2];
+ UNUSED(denv);
+
+ kset_car(key, flag);
+ kset_cdr(key, value);
+
+ /* pass to next interceptor/ final destination */
+ /* ptree is as for interceptors: (obj divert) */
+ TValue obj = kcar(ptree);
+ kapply_cc(K, obj);
+}
+
+/* /Continuations that are used in more than one file */
+
+/* dynamic keys */
+/* create continuation to set the key on both normal return and
+ abnormal passes */
+/* TODO: reuse the code for guards in kgcontinuations.c */
+
+/* GC: this assumes that key, old_value and new_value are rooted */
+TValue make_bind_continuation(klisp_State *K, TValue key,
+ TValue old_flag, TValue old_value,
+ TValue new_flag, TValue new_value)
+{
+ TValue unbind_cont = kmake_continuation(K, kget_cc(K),
+ do_unbind, 3, key, old_flag,
+ old_value);
+ krooted_tvs_push(K, unbind_cont);
+ /* create the guards to guarantee that the values remain consistent on
+ abnormal passes (in both directions) */
+ TValue exit_int = kmake_operative(K, do_set_pass,
+ 3, key, old_flag, old_value);
+ krooted_tvs_push(K, exit_int);
+ TValue exit_guard = kcons(K, K->root_cont, exit_int);
+ krooted_tvs_pop(K); /* already rooted in guard */
+ krooted_tvs_push(K, exit_guard);
+ TValue exit_guards = kcons(K, exit_guard, KNIL);
+ krooted_tvs_pop(K); /* already rooted in guards */
+ krooted_tvs_push(K, exit_guards);
+
+ TValue entry_int = kmake_operative(K, do_set_pass,
+ 3, key, new_flag, new_value);
+ krooted_tvs_push(K, entry_int);
+ TValue entry_guard = kcons(K, K->root_cont, entry_int);
+ krooted_tvs_pop(K); /* already rooted in guard */
+ krooted_tvs_push(K, entry_guard);
+ TValue entry_guards = kcons(K, entry_guard, KNIL);
+ krooted_tvs_pop(K); /* already rooted in guards */
+ krooted_tvs_push(K, entry_guards);
+
+
+ /* NOTE: in the stack now we have the unbind cont & two guard lists */
+ /* this is needed for interception code */
+ TValue env = kmake_empty_environment(K);
+ krooted_tvs_push(K, env);
+ TValue outer_cont = kmake_continuation(K, unbind_cont,
+ do_pass_value, 2, entry_guards, env);
+ kset_outer_cont(outer_cont);
+ krooted_tvs_push(K, outer_cont);
+ TValue inner_cont = kmake_continuation(K, outer_cont,
+ do_pass_value, 2, exit_guards, env);
+ kset_inner_cont(inner_cont);
+
+ /* unbind_cont & 2 guard_lists */
+ krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
+ /* env & outer_cont */
+ krooted_tvs_pop(K); krooted_tvs_pop(K);
+
+ return inner_cont;
+}
+
+/* Helpers for guard-continuation (& guard-dynamic-extent) */
+
+#define singly_wrapped(obj_) (ttisapplicative(obj_) && \
+ ttisoperative(kunwrap(obj_)))
+
+/* this unmarks root before throwing any error */
+/* TODO: this isn't very clean, refactor */
+
+/* GC: assumes obj & root are rooted, dummy1 is in use */
+inline TValue check_copy_single_entry(klisp_State *K, char *name,
+ TValue obj, TValue root)
+{
+ if (!ttispair(obj) || !ttispair(kcdr(obj)) ||
+ !ttisnil(kcddr(obj))) {
+ unmark_list(K, root);
+ klispE_throw_simple(K, "Bad entry (expected list of length 2)");
+ return KINERT;
+ }
+ TValue cont = kcar(obj);
+ TValue app = kcadr(obj);
+
+ if (!ttiscontinuation(cont)) {
+ unmark_list(K, root);
+ klispE_throw_simple(K, "Bad type on first element (expected "
+ "continuation)");
+ return KINERT;
+ } else if (!singly_wrapped(app)) {
+ unmark_list(K, root);
+ klispE_throw_simple(K, "Bad type on second element (expected "
+ "singly wrapped applicative)");
+ return KINERT;
+ }
+
+ /* save the operative directly, don't waste space/time
+ with a list, use just a pair */
+ return kcons(K, cont, kunwrap(app));
+}
+
+/* the guards are probably generated on the spot so we don't check
+ for immutability and copy it anyways */
+/* GC: Assumes obj is rooted */
+TValue check_copy_guards(klisp_State *K, char *name, TValue obj)
+{
+ if (ttisnil(obj)) {
+ return obj;
+ } else {
+ TValue last_pair = kget_dummy1(K);
+ TValue tail = obj;
+
+ while(ttispair(tail) && !kis_marked(tail)) {
+ /* this will clear the marks and throw an error if the structure
+ is incorrect */
+ TValue entry = check_copy_single_entry(K, name, kcar(tail), obj);
+ krooted_tvs_push(K, entry);
+ TValue new_pair = kcons(K, entry, KNIL);
+ krooted_tvs_pop(K);
+ kmark(tail);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ tail = kcdr(tail);
+ }
+
+ /* dont close the cycle (if there is one) */
+ unmark_list(K, obj);
+ TValue ret = kcutoff_dummy1(K);
+ if (!ttispair(tail) && !ttisnil(tail)) {
+ klispE_throw_simple(K, "expected list");
+ return KINERT;
+ }
+ return ret;
+ }
+}
+
+void guard_dynamic_extent(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);
+
+ bind_3tp(K, ptree, "any", anytype, entry_guards,
+ "combiner", ttiscombiner, comb,
+ "any", anytype, exit_guards);
+
+ entry_guards = check_copy_guards(K, "guard-dynamic-extent: entry guards",
+ entry_guards);
+ krooted_tvs_push(K, entry_guards);
+ exit_guards = check_copy_guards(K, "guard-dynamic-extent: exit guards",
+ exit_guards);
+ krooted_tvs_push(K, exit_guards);
+ /* GC: root continuations */
+ /* The current continuation is guarded */
+ TValue outer_cont = kmake_continuation(K, kget_cc(K), do_pass_value,
+ 2, entry_guards, denv);
+ kset_outer_cont(outer_cont);
+ kset_cc(K, outer_cont); /* this implicitly roots outer_cont */
+
+ TValue inner_cont = kmake_continuation(K, outer_cont, do_pass_value, 2,
+ exit_guards, denv);
+ kset_inner_cont(inner_cont);
+
+ /* call combiner with no operands in the dynamic extent of inner,
+ with the dynamic env of this call */
+ kset_cc(K, inner_cont); /* this implicitly roots inner_cont */
+ TValue expr = kcons(K, comb, KNIL);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
+ ktail_eval(K, expr, denv);
+}
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -27,6 +27,67 @@
/* to use in type checking binds when no check is needed */
#define anytype(obj_) (true)
+/* Type predicates */
+/* TODO these should be moved to either kobject.h or the corresponding
+ files (e.g. kbooleanp to kboolean.h */
+bool kbooleanp(TValue obj);
+bool kcombinerp(TValue obj);
+bool knumberp(TValue obj);
+bool knumber_wpvp(TValue obj);
+bool kfinitep(TValue obj);
+bool kintegerp(TValue obj);
+bool keintegerp(TValue obj);
+bool krationalp(TValue obj);
+bool krealp(TValue obj);
+bool kreal_wpvp(TValue obj);
+bool kexactp(TValue obj);
+bool kinexactp(TValue obj);
+bool kundefinedp(TValue obj);
+bool krobustp(TValue obj);
+bool ku8p(TValue obj);
+/* This is used in gcd & lcm */
+bool kimp_intp(TValue obj);
+
+/* needed by kgffi.c and encapsulations */
+void enc_typep(klisp_State *K);
+
+/* /Type predicates */
+
+/* some number predicates */
+/* REFACTOR: These should be in a knumber.h header */
+
+/* Misc Helpers */
+/* TEMP: only reals (no complex numbers) */
+bool kpositivep(TValue n);
+bool knegativep(TValue n);
+
+inline bool kfast_zerop(TValue n)
+{
+ return (ttisfixint(n) && ivalue(n) == 0) ||
+ (ttisdouble(n) && dvalue(n) == 0.0);
+}
+
+inline bool kfast_onep(TValue n)
+{
+ return (ttisfixint(n) && ivalue(n) == 1) ||
+ (ttisdouble(n) && dvalue(n) == 1.0);
+}
+
+inline TValue kneg_inf(TValue i)
+{
+ if (ttiseinf(i))
+ return tv_equal(i, KEPINF)? KEMINF : KEPINF;
+ else /* ttisiinf(i) */
+ return tv_equal(i, KIPINF)? KIMINF : KIPINF;
+}
+
+inline bool knum_same_signp(klisp_State *K, TValue n1, TValue n2)
+{
+ return kpositivep(n1) == kpositivep(n2);
+}
+
+/* /some number predicates */
+
/*
** NOTE: these are intended to be used at the beginning of a function
** they expand to more than one statement and may evaluate some of
@@ -265,102 +326,27 @@ inline void unmark_tree(klisp_State *K, TValue obj)
/* TODO: move all bools to a flag parameter (with constants like
KCHK_LS_FORCE_COPY, KCHK_ALLOW_CYCLE, KCHK_AVOID_ENCYCLE, etc) */
-/* REFACTOR: remove the name argument */
+/* typed finite list. Structure error are thrown before type errors */
+void check_typed_list(klisp_State *K, bool (*typep)(TValue), bool allow_infp,
+ TValue obj, int32_t *pairs, int32_t *cpairs);
-/* typed finite list. Structure error should be throw before type errors */
-int32_t check_typed_list(klisp_State *K, char *name, char *typename,
- bool (*typep)(TValue), bool allow_infp, TValue obj,
- int32_t *cpairs);
-
-/* REFACTOR: remove the name argument */
/* check that obj is a list, returns the number of pairs */
/* TODO change the return to void and add int32_t pairs obj */
-int32_t check_list(klisp_State *K, const char *name, bool allow_infp,
- TValue obj, int32_t *cpairs);
+void check_list(klisp_State *K, bool allow_infp, TValue obj,
+ int32_t *pairs, int32_t *cpairs);
-/*
-** MAYBE: These shouldn't be inline really.
-*/
-
-/* REFACTOR: remove the name argument */
-/* REFACTOR: return the number of pairs and cycle pairs in two extra params */
+/* TODO: add unchecked_copy_list */
/* TODO: add check_copy_typed_list */
-/* TODO: remove inline */
/* check that obj is a list and make a copy if it is not immutable or
force_copy is true */
/* GC: assumes obj is rooted, use dummy3 */
-inline TValue check_copy_list(klisp_State *K, char *name, TValue obj,
- bool force_copy)
-{
- if (ttisnil(obj))
- return obj;
-
- if (ttispair(obj) && kis_immutable(obj) && !force_copy) {
- UNUSED(check_list(K, name, true, obj, NULL));
- return obj;
- } else {
- TValue last_pair = kget_dummy3(K);
- TValue tail = obj;
-
- while(ttispair(tail) && !kis_marked(tail)) {
- TValue new_pair = kcons(K, kcar(tail), KNIL);
- /* record the corresponding pair to simplify cycle handling */
- kset_mark(tail, new_pair);
- /* copy the source code info */
- TValue si = ktry_get_si(K, tail);
- if (!ttisnil(si))
- kset_source_info(K, new_pair, si);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- tail = kcdr(tail);
- }
+TValue check_copy_list(klisp_State *K, TValue obj, bool force_copy,
+ int32_t *pairs, int32_t *cpairs);
- if (ttispair(tail)) {
- /* complete the cycle */
- kset_cdr(last_pair, kget_mark(tail));
- }
-
- unmark_list(K, obj);
-
- if (!ttispair(tail) && !ttisnil(tail)) {
- klispE_throw_simple(K, "expected list");
- return KINERT;
- }
- return kcutoff_dummy3(K);
- }
-}
-
-/* REFACTOR: remove the name argument */
/* check that obj is a list of environments and make a copy but don't keep
the cycles */
/* GC: assume obj is rooted, uses dummy3 */
-inline TValue check_copy_env_list(klisp_State *K, char *name, TValue obj)
-{
- TValue last_pair = kget_dummy3(K);
- TValue tail = obj;
-
- while(ttispair(tail) && !kis_marked(tail)) {
- TValue first = kcar(tail);
- if (!ttisenvironment(first)) {
- klispE_throw_simple(K, "not an environment in parent list");
- return KINERT;
- }
- TValue new_pair = kcons(K, first, KNIL);
- kmark(tail);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- tail = kcdr(tail);
- }
-
- /* even if there was a cycle, the copy ends with nil */
- unmark_list(K, obj);
-
- if (!ttispair(tail) && !ttisnil(tail)) {
- klispE_throw_simple(K, "expected list");
- return KINERT;
- }
- return kcutoff_dummy3(K);
-}
+TValue check_copy_env_list(klisp_State *K, TValue obj);
/*
** Generic function for type predicates
@@ -397,12 +383,23 @@ void ftyped_bpredp(klisp_State *K);
/* TODO unify them */
void ftyped_kbpredp(klisp_State *K);
-
-/*
-** Continuation that ignores the value received and instead returns
-** a previously computed value.
-*/
+/* Continuations that are used in more than one file */
+void do_seq(klisp_State *K);
+void do_pass_value(klisp_State *K);
void do_return_value(klisp_State *K);
+void do_bind(klisp_State *K);
+void do_access(klisp_State *K);
+void do_unbind(klisp_State *K);
+void do_set_pass(klisp_State *K);
+/* /Continuations that are used in more than one file */
+
+/* dynamic var */
+TValue make_bind_continuation(klisp_State *K, TValue key,
+ TValue old_flag, TValue old_value,
+ TValue new_flag, TValue new_value);
+
+TValue check_copy_guards(klisp_State *K, char *name, TValue obj);
+void guard_dynamic_extent(klisp_State *K);
/* GC: assumes parent & obj are rooted */
inline TValue make_return_value_cont(klisp_State *K, TValue parent, TValue obj)
@@ -434,15 +431,56 @@ int64_t klcm32_64(int32_t a, int32_t b);
** Other
*/
+/* list applicative (used in kstate and kgpairs_lists) */
+void list(klisp_State *K);
+
/* Helper for list-tail, list-ref and list-set! */
-int32_t ksmallest_index(klisp_State *K, char *name, TValue obj,
- TValue tk);
+int32_t ksmallest_index(klisp_State *K, TValue obj, TValue tk);
/* Helper for get-list-metrics, and list-tail, list-ref and list-set!
when receiving bigint indexes */
void get_list_metrics_aux(klisp_State *K, TValue obj, int32_t *p, int32_t *n,
int32_t *a, int32_t *c);
+/* Helper for eq? and equal? */
+bool eq2p(klisp_State *K, TValue obj1, TValue obj2);
+
+/* Helper for equal?, assoc and member */
+/* compare two objects and check to see if they are "equal?". */
+bool equal2p(klisp_State *K, TValue obj1, TValue obj2);
+
+/* Helper (also used by $vau, $lambda, etc) */
+TValue copy_es_immutable_h(klisp_State *K, TValue ptree, bool mut_flag);
+
+/* ptree handling */
+void match(klisp_State *K, TValue env, TValue ptree, TValue obj);
+TValue check_copy_ptree(klisp_State *K, TValue ptree, TValue penv);
+
+/* map/$for-each */
+/* Helpers for map (also used by for-each) */
+
+/* Calculate the metrics for both the result list and the ptree
+ passed to the applicative */
+void map_for_each_get_metrics(
+ klisp_State *K, TValue lss, int32_t *app_apairs_out,
+ int32_t *app_cpairs_out, int32_t *res_apairs_out, int32_t *res_cpairs_out);
+
+/* Return two lists, isomorphic to lss: one list of cars and one list
+ of cdrs (replacing the value of lss) */
+/* GC: Assumes lss is rooted, uses dummys 2 & 3 */
+TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss,
+ int32_t apairs, int32_t cpairs);
+
+/* Transpose lss so that the result is a list of lists, each one having
+ metrics (app_apairs, app_cpairs). The metrics of the returned list
+ should be (res_apairs, res_cpairs) */
+
+/* GC: Assumes lss is rooted, uses dummys 1, &
+ (through get_cars_cdrs, 2, 3) */
+TValue map_for_each_transpose(klisp_State *K, TValue lss,
+ int32_t app_apairs, int32_t app_cpairs,
+ int32_t res_apairs, int32_t res_cpairs);
+
/*
** Macros for ground environment initialization
*/
diff --git a/src/kgkd_vars.c b/src/kgkd_vars.c
@@ -20,7 +20,6 @@
#include "kerror.h"
#include "kghelpers.h"
-#include "kgcontinuations.h" /* for do_pass_value / guards */
#include "kgkd_vars.h"
/*
@@ -30,172 +29,8 @@
*/
/* Helpers for make-keyed-dynamic-variable */
+/* in kghelpers */
-/* accesor returned */
-void do_access(klisp_State *K)
-{
- TValue *xparams = K->next_xparams;
- TValue ptree = K->next_value;
- TValue denv = K->next_env;
- klisp_assert(ttisenvironment(K->next_env));
- /*
- ** xparams[0]: dynamic key
- */
- check_0p(K, ptree);
- UNUSED(denv);
- TValue key = xparams[0];
-
- if (kis_true(kcar(key))) {
- kapply_cc(K, kcdr(key));
- } else {
- klispE_throw_simple(K, "variable is unbound");
- return;
- }
-}
-
-/* continuation to set the key to the old value on normal return */
-void do_unbind(klisp_State *K)
-{
- TValue *xparams = K->next_xparams;
- TValue obj = K->next_value;
- klisp_assert(ttisnil(K->next_env));
- /*
- ** xparams[0]: dynamic key
- ** xparams[1]: old flag
- ** xparams[2]: old value
- */
-
- TValue key = xparams[0];
- TValue old_flag = xparams[1];
- TValue old_value = xparams[2];
-
- kset_car(key, old_flag);
- kset_cdr(key, old_value);
- /* pass along the value returned to this continuation */
- kapply_cc(K, obj);
-}
-
-/* operative for setting the key to the new/old flag/value */
-void do_set_pass(klisp_State *K)
-{
- TValue *xparams = K->next_xparams;
- TValue ptree = K->next_value;
- TValue denv = K->next_env;
- klisp_assert(ttisenvironment(K->next_env));
- /*
- ** xparams[0]: dynamic key
- ** xparams[1]: flag
- ** xparams[2]: value
- */
- TValue key = xparams[0];
- TValue flag = xparams[1];
- TValue value = xparams[2];
- UNUSED(denv);
-
- kset_car(key, flag);
- kset_cdr(key, value);
-
- /* pass to next interceptor/ final destination */
- /* ptree is as for interceptors: (obj divert) */
- TValue obj = kcar(ptree);
- kapply_cc(K, obj);
-}
-
-/* create continuation to set the key on both normal return and
- abnormal passes */
-/* TODO: reuse the code for guards in kgcontinuations.c */
-
-/* GC: this assumes that key, old_value and new_value are rooted */
-inline TValue make_bind_continuation(klisp_State *K, TValue key,
- TValue old_flag, TValue old_value,
- TValue new_flag, TValue new_value)
-{
- TValue unbind_cont = kmake_continuation(K, kget_cc(K),
- do_unbind, 3, key, old_flag,
- old_value);
- krooted_tvs_push(K, unbind_cont);
- /* create the guards to guarantee that the values remain consistent on
- abnormal passes (in both directions) */
- TValue exit_int = kmake_operative(K, do_set_pass,
- 3, key, old_flag, old_value);
- krooted_tvs_push(K, exit_int);
- TValue exit_guard = kcons(K, K->root_cont, exit_int);
- krooted_tvs_pop(K); /* already rooted in guard */
- krooted_tvs_push(K, exit_guard);
- TValue exit_guards = kcons(K, exit_guard, KNIL);
- krooted_tvs_pop(K); /* already rooted in guards */
- krooted_tvs_push(K, exit_guards);
-
- TValue entry_int = kmake_operative(K, do_set_pass,
- 3, key, new_flag, new_value);
- krooted_tvs_push(K, entry_int);
- TValue entry_guard = kcons(K, K->root_cont, entry_int);
- krooted_tvs_pop(K); /* already rooted in guard */
- krooted_tvs_push(K, entry_guard);
- TValue entry_guards = kcons(K, entry_guard, KNIL);
- krooted_tvs_pop(K); /* already rooted in guards */
- krooted_tvs_push(K, entry_guards);
-
-
- /* NOTE: in the stack now we have the unbind cont & two guard lists */
- /* this is needed for interception code */
- TValue env = kmake_empty_environment(K);
- krooted_tvs_push(K, env);
- TValue outer_cont = kmake_continuation(K, unbind_cont,
- do_pass_value, 2, entry_guards, env);
- kset_outer_cont(outer_cont);
- krooted_tvs_push(K, outer_cont);
- TValue inner_cont = kmake_continuation(K, outer_cont,
- do_pass_value, 2, exit_guards, env);
- kset_inner_cont(inner_cont);
-
- /* unbind_cont & 2 guard_lists */
- krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
- /* env & outer_cont */
- krooted_tvs_pop(K); krooted_tvs_pop(K);
-
- return inner_cont;
-}
-
-/* binder returned */
-void do_bind(klisp_State *K)
-{
- TValue *xparams = K->next_xparams;
- TValue ptree = K->next_value;
- TValue denv = K->next_env;
- klisp_assert(ttisenvironment(K->next_env));
- /*
- ** xparams[0]: dynamic key
- */
- bind_2tp(K, ptree, "any", anytype, obj,
- "combiner", ttiscombiner, comb);
- UNUSED(denv); /* the combiner is called in an empty environment */
- TValue key = xparams[0];
- /* GC: root intermediate objs */
- TValue new_flag = KTRUE;
- TValue new_value = obj;
- TValue old_flag = kcar(key);
- TValue old_value = kcdr(key);
- /* set the var to the new object */
- kset_car(key, new_flag);
- kset_cdr(key, new_value);
- /* Old value must be protected from GC. It is no longer
- reachable through key and not yet reachable through
- continuation xparams. Boolean flag needn't be rooted,
- because is not heap-allocated. */
- krooted_tvs_push(K, old_value);
- /* create a continuation to set the var to the correct value/flag on both
- normal return and abnormal passes */
- TValue new_cont = make_bind_continuation(K, key, old_flag, old_value,
- new_flag, new_value);
- krooted_tvs_pop(K);
- kset_cc(K, new_cont); /* implicit rooting */
- TValue env = kmake_empty_environment(K);
- krooted_tvs_push(K, env);
- TValue expr = kcons(K, comb, KNIL);
- krooted_tvs_pop(K);
- ktail_eval(K, expr, env)
-}
/* 10.1.1 make-keyed-dynamic-variable */
void make_keyed_dynamic_variable(klisp_State *K)
diff --git a/src/kgkd_vars.h b/src/kgkd_vars.h
@@ -7,25 +7,7 @@
#ifndef kgkd_vars_h
#define kgkd_vars_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* This is also used by kgports.c */
-void do_bind(klisp_State *K);
-void do_access(klisp_State *K);
-
-/* 10.1.1 make-keyed-dynamic-variable */
-void make_keyed_dynamic_variable(klisp_State *K);
-
-void do_unbind(klisp_State *K);
/* init ground */
void kinit_kgkd_vars_ground_env(klisp_State *K);
diff --git a/src/kgks_vars.h b/src/kgks_vars.h
@@ -7,19 +7,7 @@
#ifndef kgks_vars_h
#define kgks_vars_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* 11.1.1 make-static-dynamic-variable */
-void make_keyed_static_variable(klisp_State *K);
/* init ground */
void kinit_kgks_vars_ground_env(klisp_State *K);
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -28,42 +28,10 @@
#include "kghelpers.h"
#include "kgnumbers.h"
-#include "kgkd_vars.h" /* for strict arith flag */
/* 15.5.1? number?, finite?, integer? */
/* use ftypep & ftypep_predp */
-/* Helpers for typed predicates */
-bool knumberp(TValue obj) { return ttisnumber(obj); }
-/* TEMP used (as a type predicate) in all predicates that need a primary value
- (XXX it's not actually a type error, but it's close enough and otherwise
- should define new predp & bpredp for numeric predicates...) */
-bool knumber_wpvp(TValue obj)
-{
- return ttisnumber(obj) && !ttisrwnpv(obj) && !ttisundef(obj);
-}
-/* This is used in gcd & lcm */
-bool kimp_intp(TValue obj) { return ttisinteger(obj) || ttisinf(obj); }
-/* obj is known to be a number */
-bool kfinitep(TValue obj) { return !ttisinf(obj); }
-/* fixint, bigints & inexact integers */
-bool kintegerp(TValue obj) { return ttisinteger(obj); }
-/* only exact integers (like for indices), bigints & fixints */
-bool keintegerp(TValue obj) { return ttiseinteger(obj); }
-/* exact integers between 0 and 255 inclusive */
-bool ku8p(TValue obj) { return ttisu8(obj); }
-bool krationalp(TValue obj) { return ttisrational(obj); }
-bool krealp(TValue obj) { return ttisreal(obj); }
-/* TEMP used (as a type predicate) in all predicates that need a real with
- primary value (XXX it's not actually a type error, but it's close enough
- and otherwise should define new predp & bpredp for numeric predicates...) */
-bool kreal_wpvp(TValue obj) { return ttisreal(obj) && !ttisrwnpv(obj); }
-
-bool kexactp(TValue obj) { return ttisexact(obj); }
-bool kinexactp(TValue obj) { return ttisinexact(obj); }
-bool kundefinedp(TValue obj) { return ttisundef(obj); }
-bool krobustp(TValue obj) { return ttisrobust(obj); }
-
/* 12.5.2 =? */
/* uses typed_bpredp */
@@ -907,9 +875,8 @@ void kplus(klisp_State *K)
UNUSED(denv);
UNUSED(xparams);
/* cycles are allowed, loop counting pairs */
- int32_t cpairs;
- int32_t pairs = check_typed_list(K, "+", "number", knumberp,
- true, ptree, &cpairs);
+ int32_t pairs, cpairs;
+ check_typed_list(K, knumberp, true, ptree, &pairs, &cpairs);
int32_t apairs = pairs - cpairs;
TValue res;
@@ -978,9 +945,8 @@ void ktimes(klisp_State *K)
UNUSED(denv);
UNUSED(xparams);
/* cycles are allowed, loop counting pairs */
- int32_t cpairs;
- int32_t pairs = check_typed_list(K, "*", "number", knumberp, true,
- ptree, &cpairs);
+ int32_t pairs, cpairs;
+ check_typed_list(K, knumberp, true, ptree, &pairs, &cpairs);
int32_t apairs = pairs - cpairs;
TValue res;
@@ -1060,7 +1026,7 @@ void kminus(klisp_State *K)
UNUSED(denv);
UNUSED(xparams);
/* cycles are allowed, loop counting pairs */
- int32_t cpairs;
+ int32_t pairs, cpairs;
/* - in kernel (and unlike in scheme) requires at least 2 arguments */
if (!ttispair(ptree) || !ttispair(kcdr(ptree))) {
@@ -1071,8 +1037,7 @@ void kminus(klisp_State *K)
return;
}
TValue first_val = kcar(ptree);
- int32_t pairs = check_typed_list(K, "-", "number", knumberp, true,
- kcdr(ptree), &cpairs);
+ check_typed_list(K, knumberp, true, kcdr(ptree), &pairs, &cpairs);
int32_t apairs = pairs - cpairs;
TValue res;
@@ -1206,6 +1171,11 @@ int32_t kfixint_div0_mod0(int32_t n, int32_t d, int32_t *res_mod)
return div;
}
+/* Helper for div and mod */
+#define FDIV_DIV 1
+#define FDIV_MOD 2
+#define FDIV_ZERO 4
+
/* flags are FDIV_DIV, FDIV_MOD, FDIV_ZERO */
void kdiv_mod(klisp_State *K)
{
@@ -1374,48 +1344,7 @@ void kdiv_mod(klisp_State *K)
/* use ftyped_predp */
/* Helpers for positive?, negative?, odd? & even? */
-bool kpositivep(TValue n)
-{
- switch (ttype(n)) {
- case K_TFIXINT:
- case K_TEINF:
- case K_TIINF:
- return ivalue(n) > 0;
- case K_TBIGINT:
- return kbigint_positivep(n);
- case K_TBIGRAT:
- return kbigrat_positivep(n);
- case K_TDOUBLE:
- return dvalue(n) > 0.0;
- /* real with no prim value, complex and undefined should be captured by
- type predicate */
- default:
- klisp_assert(0);
- return false;
- }
-}
-
-bool knegativep(TValue n)
-{
- switch (ttype(n)) {
- case K_TFIXINT:
- case K_TEINF:
- case K_TIINF:
- return ivalue(n) < 0;
- case K_TBIGINT:
- return kbigint_negativep(n);
- case K_TBIGRAT:
- return kbigrat_negativep(n);
- case K_TDOUBLE:
- return dvalue(n) < 0.0;
- /* real with no prim value, complex and undefined should be captured by
- type predicate */
- default:
- klisp_assert(0);
- return false;
- }
-}
-
+/* positive and negative, in kghelpers */
/* n is finite, integer */
bool koddp(TValue n)
{
@@ -1467,6 +1396,9 @@ void kabs(klisp_State *K)
kapply_cc(K, res);
}
+#define FMIN (true)
+#define FMAX (false)
+
/* 12.5.13 min, max */
/* NOTE: this does two passes, one for error checking and one for doing
the actual work */
@@ -1482,21 +1414,15 @@ void kmin_max(klisp_State *K)
*/
UNUSED(denv);
- char *name = ksymbol_buf(xparams[0]);
bool minp = bvalue(xparams[1]);
/* cycles are allowed, loop counting pairs */
- int32_t dummy; /* don't care about count of cycle pairs */
- int32_t pairs = check_typed_list(K, name, "number", knumberp, true, ptree,
- &dummy);
+ int32_t pairs;
+ check_typed_list(K, knumberp, true, ptree, &pairs, NULL);
TValue res;
- if (minp) {
- res = KEPINF;
- } else {
- res = KEMINF;
- }
+ res = minp? KEPINF : KEMINF;
TValue tail = ptree;
bool (*cmp)(klisp_State *K, TValue, TValue) = minp? knum_ltp : knum_gtp;
@@ -1521,8 +1447,8 @@ void kgcd(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
/* cycles are allowed, loop counting pairs */
- int32_t pairs = check_typed_list(K, "gcd", "improper integer", kimp_intp,
- true, ptree, NULL);
+ int32_t pairs;
+ check_typed_list(K, kimp_intp, true, ptree, &pairs, NULL);
TValue res = i2tv(0);
krooted_vars_push(K, &res);
@@ -1559,8 +1485,8 @@ void klcm(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
/* cycles are allowed, loop counting pairs */
- int32_t pairs = check_typed_list(K, "lcm", "improper integer", kimp_intp,
- true, ptree, NULL);
+ int32_t pairs;
+ check_typed_list(K, kimp_intp, true, ptree, &pairs, NULL);
/* report: this will cover the case of (lcm) = 1 */
TValue res = i2tv(1);
@@ -1775,7 +1701,7 @@ void kdivided(klisp_State *K)
UNUSED(denv);
UNUSED(xparams);
/* cycles are allowed, loop counting pairs */
- int32_t cpairs;
+ int32_t pairs, cpairs;
/* / in kernel (and unlike in scheme) requires at least 2 arguments */
if (!ttispair(ptree) || !ttispair(kcdr(ptree))) {
@@ -1786,8 +1712,7 @@ void kdivided(klisp_State *K)
return;
}
TValue first_val = kcar(ptree);
- int32_t pairs = check_typed_list(K, "/", "number", knumberp, true,
- kcdr(ptree), &cpairs);
+ check_typed_list(K, knumberp, true, kcdr(ptree), &pairs, &cpairs);
int32_t apairs = pairs - cpairs;
TValue res;
diff --git a/src/kgnumbers.h b/src/kgnumbers.h
@@ -7,209 +7,7 @@
#ifndef kgnumbers_h
#define kgnumbers_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* 15.5.1 number?, finite?, integer? */
-/* use ftypep & ftypep_predp */
-
-/* Helpers for typed predicates */
-/* XXX: this should probably be in a file knumber.h but there is no real need for
- that file yet */
-bool knumberp(TValue obj);
-bool knumber_wpvp(TValue obj);
-bool kfinitep(TValue obj);
-bool kintegerp(TValue obj);
-bool keintegerp(TValue obj);
-bool krationalp(TValue obj);
-bool krealp(TValue obj);
-bool kreal_wpvp(TValue obj);
-bool kexactp(TValue obj);
-bool kinexactp(TValue obj);
-bool kundefinedp(TValue obj);
-bool krobustp(TValue obj);
-bool ku8p(TValue obj);
-
-
-/* 12.5.2 =? */
-/* uses typed_bpredp */
-
-/* 12.5.3 <?, <=?, >?, >=? */
-/* use typed_bpredp */
-
-/* Helpers for typed binary predicates */
-/* XXX: this should probably be in a file knumber.h but there is no real need for
- that file yet */
-bool knum_eqp(klisp_State *K, TValue n1, TValue n2);
-bool knum_ltp(klisp_State *K, TValue n1, TValue n2);
-bool knum_lep(klisp_State *K, TValue n1, TValue n2);
-bool knum_gtp(klisp_State *K, TValue n1, TValue n2);
-bool knum_gep(klisp_State *K, TValue n1, TValue n2);
-
-/* 12.5.4 + */
-/* TEMP: for now only accept two arguments */
-void kplus(klisp_State *K);
-
-/* 12.5.5 * */
-/* TEMP: for now only accept two arguments */
-void ktimes(klisp_State *K);
-
-/* 12.5.6 - */
-/* TEMP: for now only accept two arguments */
-void kminus(klisp_State *K);
-
-/* 12.5.7 zero? */
-/* uses ftyped_predp */
-
-/* Helper for zero? */
-bool kzerop(TValue n);
-
-/* 12.5.8 div, mod, div-and-mod */
-/* TODO */
-
-/* 12.5.9 div0, mod0, div0-and-mod0 */
-/* TODO */
-
-/* 12.5.10 positive?, negative? */
-/* use ftyped_predp */
-
-/* 12.5.11 odd?, even? */
-/* use ftyped_predp */
-
-/* Helpers for positive?, negative?, odd? & even? */
-bool kpositivep(TValue n);
-bool knegativep(TValue n);
-bool koddp(TValue n);
-bool kevenp(TValue n);
-
-/* 12.5.8 div, mod, div-and-mod */
-/* use div_mod */
-
-/* 12.5.9 div0, mod0, div0-and-mod0 */
-/* use div_mod */
-
-/* Helper for div and mod */
-#define FDIV_DIV 1
-#define FDIV_MOD 2
-#define FDIV_ZERO 4
-
-void kdiv_mod(klisp_State *K);
-
-
-/* 12.5.12 abs */
-void kabs(klisp_State *K);
-
-/* 12.5.13 min, max */
-/* use kmin_max */
-
-/* Helper */
-#define FMIN (true)
-#define FMAX (false)
-void kmin_max(klisp_State *K);
-
-/* 12.5.14 gcm, lcm */
-void kgcd(klisp_State *K);
-void klcm(klisp_State *K);
-
-/* 12.6.1 exact?, inexact?, robust?, undefined? */
-/* use fyped_predp */
-
-/* 12.6.2 get-real-internal-bounds, get-real-exact-bounds */
-void kget_real_internal_bounds(klisp_State *K);
-void kget_real_exact_bounds(klisp_State *K);
-
-/* 12.6.3 get-real-internal-primary, get-real-exact-primary */
-void kget_real_internal_primary(klisp_State *K);
-void kget_real_exact_primary(klisp_State *K);
-
-/* 12.6.4 make-inexact */
-void kmake_inexact(klisp_State *K);
-
-/* 12.6.5 real->inexact, real->exact */
-void kreal_to_inexact(klisp_State *K);
-void kreal_to_exact(klisp_State *K);
-
-/* 12.6.6 with-strict-arithmetic, get-strict-arithmetic? */
-void kwith_strict_arithmetic(klisp_State *K);
-
-void kget_strict_arithmeticp(klisp_State *K);
-
-/* 12.8.1 rational? */
-/* uses ftypep */
-
-/* 12.8.2 / */
-void kdivided(klisp_State *K);
-
-/* 12.8.3 numerator, denominator */
-void knumerator(klisp_State *K);
-void kdenominator(klisp_State *K);
-
-/* 12.8.4 floor, ceiling, truncate, round */
-void kreal_to_integer(klisp_State *K);
-
-/* 12.8.5 rationalize, simplest-rational */
-void krationalize(klisp_State *K);
-
-void ksimplest_rational(klisp_State *K);
-
-
-/* 12.9.1 real? */
-/* uses ftypep */
-
-/* 12.9.2 exp, log */
-void kexp(klisp_State *K);
-void klog(klisp_State *K);
-
-/* 12.9.3 sin, cos, tan */
-void ktrig(klisp_State *K);
-
-/* 12.9.4 asin, acos, atan */
-void katrig(klisp_State *K);
-void katan(klisp_State *K);
-
-/* 12.9.5 sqrt */
-void ksqrt(klisp_State *K);
-
-/* 12.9.6 expt */
-void kexpt(klisp_State *K);
-
-
-/* REFACTOR: These should be in a knumber.h header */
-
-/* Misc Helpers */
-/* TEMP: only reals (no complex numbers) */
-inline bool kfast_zerop(TValue n)
-{
- return (ttisfixint(n) && ivalue(n) == 0) ||
- (ttisdouble(n) && dvalue(n) == 0.0);
-}
-
-inline bool kfast_onep(TValue n)
-{
- return (ttisfixint(n) && ivalue(n) == 1) ||
- (ttisdouble(n) && dvalue(n) == 1.0);
-}
-
-inline TValue kneg_inf(TValue i)
-{
- if (ttiseinf(i))
- return tv_equal(i, KEPINF)? KEMINF : KEPINF;
- else /* ttisiinf(i) */
- return tv_equal(i, KIPINF)? KIMINF : KIPINF;
-}
-
-inline bool knum_same_signp(klisp_State *K, TValue n1, TValue n2)
-{
- return kpositivep(n1) == kpositivep(n2);
-}
/* init ground */
void kinit_numbers_ground_env(klisp_State *K);
diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c
@@ -19,8 +19,6 @@
#include "kghelpers.h"
#include "kgpair_mut.h"
-#include "kgeqp.h" /* eq? checking in memq and assq */
-#include "kgnumbers.h" /* for kpositivep and keintegerp */
/* 4.7.1 set-car!, set-cdr! */
void set_carB(klisp_State *K)
@@ -75,98 +73,16 @@ void copy_es(klisp_State *K)
** xparams[0]: copy-es-immutable symbol
** xparams[1]: boolean (#t: use mutable pairs, #f: use immutable pairs)
*/
- char *name = ksymbol_buf(xparams[0]);
bool mut_flag = bvalue(xparams[1]);
bind_1p(K, ptree, obj);
- TValue copy = copy_es_immutable_h(K, name, obj, mut_flag);
+ TValue copy = copy_es_immutable_h(K, obj, mut_flag);
kapply_cc(K, copy);
}
/* 4.7.2 copy-es-immutable */
/* uses copy_es */
-/*
-** This is in a helper method to use it from $lambda, $vau, etc
-**
-** We mark each seen mutable pair with the corresponding copied
-** immutable pair to construct a structure that is isomorphic to
-** the original.
-** All objects that aren't mutable pairs are retained without
-** copying
-** sstack is used to keep track of pairs and tbstack is used
-** to keep track of which of car or cdr we were copying,
-** 0 means just pushed, 1 means return from car, 2 means return from cdr
-**
-** This also copies source code info
-**
-*/
-
-/* GC: assumes obj is rooted */
-TValue copy_es_immutable_h(klisp_State *K, char *name, TValue obj,
- bool mut_flag)
-{
- TValue copy = obj;
- krooted_vars_push(K, ©);
-
- assert(ks_sisempty(K));
- assert(ks_tbisempty(K));
-
- ks_spush(K, obj);
- ks_tbpush(K, ST_PUSH);
-
- while(!ks_sisempty(K)) {
- char state = ks_tbpop(K);
- TValue top = ks_spop(K);
-
- if (state == ST_PUSH) {
- /* if the pair is immutable & we are constructing immutable
- pairs there is no need to copy */
- if (ttispair(top) && (mut_flag || kis_mutable(top))) {
- if (kis_marked(top)) {
- /* this pair was already seen, use the same */
- copy = kget_mark(top);
- } else {
- TValue new_pair = kcons_g(K, mut_flag, KINERT, KINERT);
- kset_mark(top, new_pair);
- /* save the source code info on the new pair */
- /* MAYBE: only do it if mutable */
- TValue si = ktry_get_si(K, top);
- if (!ttisnil(si))
- kset_source_info(K, new_pair, si);
- /* leave the pair in the stack, continue with the car */
- ks_spush(K, top);
- ks_tbpush(K, ST_CAR);
-
- ks_spush(K, kcar(top));
- ks_tbpush(K, ST_PUSH);
- }
- } else {
- copy = top;
- }
- } else { /* last action was a pop */
- TValue new_pair = kget_mark(top);
- if (state == ST_CAR) {
- /* new_pair may be immutable */
- kset_car_unsafe(K, new_pair, copy);
- /* leave the pair on the stack, continue with the cdr */
- ks_spush(K, top);
- ks_tbpush(K, ST_CDR);
-
- ks_spush(K, kcdr(top));
- ks_tbpush(K, ST_PUSH);
- } else {
- /* new_pair may be immutable */
- kset_cdr_unsafe(K, new_pair, copy);
- copy = new_pair;
- }
- }
- }
- unmark_tree(K, obj);
- krooted_vars_pop(K);
- return copy;
-}
-
/* 5.8.1 encycle! */
void encycleB(klisp_State *K)
{
@@ -286,7 +202,7 @@ void list_setB(klisp_State *K)
}
int32_t k = (ttisfixint(tk))? ivalue(tk)
- : ksmallest_index(K, "list-set!", obj, tk);
+ : ksmallest_index(K, obj, tk);
while(k) {
if (!ttispair(obj)) {
@@ -481,12 +397,11 @@ void appendB(klisp_State *K)
}
TValue lss = ptree;
TValue first_ls = kcar(lss);
- int32_t cpairs;
+ int32_t pairs, cpairs;
/* ASK John: if encycle! has only one argument, can't it be cyclic?
the report says no, but the wording is poor */
- int32_t pairs = check_list(K, "append!", false, first_ls, &cpairs);
-
- pairs = check_list(K, "append!", true, lss, &cpairs);
+ check_list(K, false, first_ls, NULL, NULL);
+ check_list(K, true, lss, &pairs, &cpairs);
int32_t apairs = pairs - cpairs;
TValue endpoints =
@@ -519,8 +434,8 @@ void assq(klisp_State *K)
bind_2p(K, ptree, obj, ls);
/* first pass, check structure */
- int32_t pairs = check_typed_list(K, "assq", "pair", kpairp,
- true, ls, NULL);
+ int32_t pairs;
+ check_typed_list(K, kpairp, true, ls, &pairs, NULL);
TValue tail = ls;
TValue res = KNIL;
while(pairs--) {
@@ -548,7 +463,8 @@ void memqp(klisp_State *K)
bind_2p(K, ptree, obj, ls);
/* first pass, check structure */
- int32_t pairs = check_list(K, "memq?", true, ls, NULL);
+ int32_t pairs;
+ check_list(K, true, ls, &pairs, NULL);
TValue tail = ls;
TValue res = KFALSE;
while(pairs--) {
diff --git a/src/kgpair_mut.h b/src/kgpair_mut.h
@@ -7,50 +7,7 @@
#ifndef kgpairs_mut_h
#define kgpairs_mut_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* Helper (also used by $vau, $lambda, etc) */
-TValue copy_es_immutable_h(klisp_State *K, char *name, TValue ptree,
- bool mut_flag);
-
-/* 4.7.1 set-car!, set-cdr! */
-void set_carB(klisp_State *K);
-
-void set_cdrB(klisp_State *K);
-
-/* Helper for copy-es & copy-es-immutable */
-void copy_es(klisp_State *K);
-
-/* 4.7.2 copy-es-immutable */
-/* uses copy_es helper */
-
-
-/* 5.8.1 encycle! */
-void encycleB(klisp_State *K);
-
-/* 6.4.1 append! */
-void appendB(klisp_State *K);
-
-/* 6.4.2 copy-es */
-/* uses copy_es helper */
-
-/* 6.4.3 assq */
-void assq(klisp_State *K);
-
-/* 6.4.3 memq? */
-void memqp(klisp_State *K);
-
-/* ?.? immutable-pair?, mutable-pair */
-/* use ftypep */
/* init ground */
void kinit_pair_mut_ground_env(klisp_State *K);
diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c
@@ -20,9 +20,7 @@
#include "kerror.h"
#include "kghelpers.h"
-#include "kgequalp.h"
#include "kgpairs_lists.h"
-#include "kgnumbers.h"
/* 4.6.1 pair? */
/* uses typep */
@@ -46,18 +44,7 @@ void cons(klisp_State *K)
}
/* 5.2.1 list */
-void list(klisp_State *K)
-{
- TValue *xparams = K->next_xparams;
- TValue ptree = K->next_value;
- TValue denv = K->next_env;
- klisp_assert(ttisenvironment(K->next_env));
-/* the underlying combiner of list return the complete ptree, the only list
- checking is implicit in the applicative evaluation */
- UNUSED(xparams);
- UNUSED(denv);
- kapply_cc(K, ptree);
-}
+/* defined in kghelpers.h (for use in kstate) */
/* 5.2.2 list* */
void listS(klisp_State *K)
@@ -110,6 +97,16 @@ void listS(klisp_State *K)
}
}
+/* Helper macros to construct xparams[1] for c[ad]{1,4}r */
+#define C_AD_R_PARAM(len_, br_) \
+ (i2tv((C_AD_R_LEN(len_) | (C_AD_R_BRANCH(br_)))))
+#define C_AD_R_LEN(len_) ((len_) << 4)
+#define C_AD_R_BRANCH(br_) \
+ ((br_ & 0x0001? 0x1 : 0) | \
+ (br_ & 0x0010? 0x2 : 0) | \
+ (br_ & 0x0100? 0x4 : 0) | \
+ (br_ & 0x1000? 0x8 : 0))
+
/* 5.4.1 car, cdr */
/* 5.4.2 caar, cadr, ... cddddr */
void c_ad_r(klisp_State *K)
@@ -198,7 +195,7 @@ void list_copy(klisp_State *K)
UNUSED(denv);
bind_1p(K, ptree, ls);
- TValue copy = check_copy_list(K, "list-copy", ls, true);
+ TValue copy = check_copy_list(K, ls, true, NULL, NULL);
kapply_cc(K, copy);
}
@@ -275,7 +272,7 @@ void list_tail(klisp_State *K)
}
int32_t k = (ttisfixint(tk))? ivalue(tk)
- : ksmallest_index(K, "list-tail", obj, tk);
+ : ksmallest_index(K, obj, tk);
while(k) {
if (!ttispair(obj)) {
@@ -336,7 +333,7 @@ void list_ref(klisp_State *K)
}
int32_t k = (ttisfixint(tk))? ivalue(tk)
- : ksmallest_index(K, "list-tail", obj, tk);
+ : ksmallest_index(K, obj, tk);
while(k) {
if (!ttispair(obj)) {
@@ -403,8 +400,8 @@ void append(klisp_State *K)
UNUSED(xparams);
UNUSED(denv);
- int32_t cpairs;
- int32_t pairs = check_list(K, "append", true, ptree, &cpairs);
+ int32_t pairs, cpairs;
+ check_list(K, true, ptree, &pairs, &cpairs);
int32_t apairs = pairs - cpairs;
/* use dummy2, append_check_copy uses dummy1 */
@@ -471,8 +468,8 @@ void list_neighbors(klisp_State *K)
bind_1p(K, ptree, ls);
- int32_t cpairs;
- int32_t pairs = check_list(K, "list_neighbors", true, ls, &cpairs);
+ int32_t pairs, cpairs;
+ check_list(K, true, ls, &pairs, &cpairs);
TValue tail = ls;
int32_t count = cpairs? pairs - cpairs : pairs - 1;
@@ -527,7 +524,7 @@ void do_ret_cdr(klisp_State *K)
/* XXX: the check isn't necessary really, but there is
no list_copy (and if there was it would take apairs and
cpairs, which we don't have here */
- TValue copy = check_copy_list(K, "filter", kcdr(xparams[0]), true);
+ TValue copy = check_copy_list(K, kcdr(xparams[0]), true, NULL, NULL);
kapply_cc(K, copy);
}
@@ -563,7 +560,7 @@ void do_filter_encycle(klisp_State *K)
/* XXX: the check isn't necessary really, but there is
no list_copy (and if there was it would take apairs and
cpairs, which we don't have here */
- TValue copy = check_copy_list(K, "filter", kcdr(xparams[0]), true);
+ TValue copy = check_copy_list(K, kcdr(xparams[0]), true, NULL, NULL);
kapply_cc(K, copy);
}
@@ -669,12 +666,12 @@ void filter(klisp_State *K)
/* ASK John: the semantics when this is mixed with continuations,
isn't all that great..., but what are the expectations considering
there is no prescribed order? */
- int32_t cpairs;
- int32_t pairs = check_list(K, "filter", true, ls, &cpairs);
+ int32_t pairs, cpairs;
+ check_list(K, true, ls, &pairs, &cpairs);
/* XXX: This was the paradigmatic use case of the force copy flag
in the old implementation, but it caused problems with continuations
Is there any other use case for force copy flag?? */
- ls = check_copy_list(K, "filter", ls, false);
+ ls = check_copy_list(K, ls, false, NULL, NULL);
/* This will be the list to be returned, but it will be copied
before to play a little nicer with continuations */
TValue dummy = kcons(K, KINERT, KNIL);
@@ -710,8 +707,8 @@ void assoc(klisp_State *K)
bind_2p(K, ptree, obj, ls);
/* first pass, check structure */
- int32_t pairs = check_typed_list(K, "assoc", "pair", kpairp,
- true, ls, NULL);
+ int32_t pairs;
+ check_typed_list(K, kpairp, true, ls, &pairs, NULL);
TValue tail = ls;
TValue res = KNIL;
while(pairs--) {
@@ -738,7 +735,8 @@ void memberp(klisp_State *K)
bind_2p(K, ptree, obj, ls);
/* first pass, check structure */
- int32_t pairs = check_list(K, "member?", true, ls, NULL);
+ int32_t pairs;
+ check_list(K, true, ls, &pairs, NULL);
TValue tail = ls;
TValue res = KFALSE;
while(pairs--) {
@@ -763,7 +761,8 @@ void finite_listp(klisp_State *K)
klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
- int32_t pairs = check_list(K, "finite-list?", true, ptree, NULL);
+ int32_t pairs;
+ check_list(K, true, ptree, &pairs, NULL);
TValue res = KTRUE;
TValue tail = ptree;
@@ -795,7 +794,8 @@ void countable_listp(klisp_State *K)
klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
- int32_t pairs = check_list(K, "countable-list?", true, ptree, NULL);
+ int32_t pairs;
+ check_list(K, true, ptree, &pairs, NULL);
TValue res = KTRUE;
TValue tail = ptree;
@@ -1044,12 +1044,11 @@ void reduce(klisp_State *K)
}
/* TODO all of these in one procedure */
- int32_t cpairs;
- int32_t pairs = check_list(K, "reduce", true, ls, &cpairs);
- int32_t apairs = pairs - cpairs;
+ int32_t pairs, cpairs;
/* force copy to be able to do all precycles and replace
the corresponding objs in ls */
- ls = check_copy_list(K, "reduce", ls, true);
+ ls = check_copy_list(K, ls, true, &pairs, &cpairs);
+ int32_t apairs = pairs - cpairs;
TValue first_cycle_pair = ls;
int32_t dapairs = apairs;
/* REFACTOR: add an extra return value to check_copy_list to output
diff --git a/src/kgpairs_lists.h b/src/kgpairs_lists.h
@@ -7,93 +7,8 @@
#ifndef kgpairs_lists_h
#define kgpairs_lists_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* 4.6.1 pair? */
-/* uses typep */
-
-/* 4.6.2 null? */
-/* uses typep */
-/* 4.6.3 cons */
-void cons(klisp_State *K);
-
-/* 5.2.1 list */
-void list(klisp_State *K);
-
-/* 5.2.2 list* */
-void listS(klisp_State *K);
-
-/* 5.4.1 car, cdr */
-/* 5.4.2 caar, cadr, ... cddddr */
-void c_ad_r(klisp_State *K);
-
-/* Helper macros to construct xparams[1] for c[ad]{1,4}r */
-#define C_AD_R_PARAM(len_, br_) \
- (i2tv((C_AD_R_LEN(len_) | (C_AD_R_BRANCH(br_)))))
-#define C_AD_R_LEN(len_) ((len_) << 4)
-#define C_AD_R_BRANCH(br_) \
- ((br_ & 0x0001? 0x1 : 0) | \
- (br_ & 0x0010? 0x2 : 0) | \
- (br_ & 0x0100? 0x4 : 0) | \
- (br_ & 0x1000? 0x8 : 0))
-
-/* 5.7.1 get-list-metrics */
-void get_list_metrics(klisp_State *K);
-
-/* 5.7.2 list-tail */
-void list_tail(klisp_State *K);
-
-/* 6.3.1 length */
-void length(klisp_State *K);
-
-/* 6.3.2 list-ref */
-void list_ref(klisp_State *K);
-
-/* 6.3.3 append */
-void append(klisp_State *K);
-
-/* 6.3.4 list-neighbors */
-void list_neighbors(klisp_State *K);
-
-/* 6.3.5 filter */
-void filter(klisp_State *K);
-
-/* 6.3.6 assoc */
-void assoc(klisp_State *K);
-
-/* 6.3.7 member? */
-void memberp(klisp_State *K);
-
-/* 6.3.8 finite-list? */
-void finite_listp(klisp_State *K);
-
-/* 6.3.9 countable-list? */
-void countable_listp(klisp_State *K);
-
-/* 6.3.10 reduce */
-void reduce(klisp_State *K);
-
-
-void do_ret_cdr(klisp_State *K);
-void do_filter_encycle(klisp_State *K);
-void do_filter_cycle(klisp_State *K);
-void do_filter(klisp_State *K);
-void do_reduce_prec(klisp_State *K);
-void do_reduce_postc(klisp_State *K);
-void do_reduce_combine(klisp_State *K);
-void do_reduce_cycle(klisp_State *K);
-void do_reduce(klisp_State *K);
-
/* init ground */
void kinit_pairs_lists_ground_env(klisp_State *K);
diff --git a/src/kgports.c b/src/kgports.c
@@ -29,9 +29,6 @@
#include "kghelpers.h"
#include "kgports.h"
-#include "kgcontinuations.h" /* for guards */
-#include "kgcontrol.h" /* for evaling in sequence */
-#include "kgkd_vars.h" /* for dynamic input/output port */
/* 15.1.1 port? */
/* uses typep */
diff --git a/src/kgports.h b/src/kgports.h
@@ -7,103 +7,7 @@
#ifndef kgports_h
#define kgports_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* 15.1.1 port? */
-/* uses typep */
-
-/* 15.1.2 input-port?, output-port? */
-/* use ftypep */
-
-/* 15.1.? binary-port?, textual-port? */
-/* use ftypep */
-
-/* 15.1.? file-port?, string-port?, bytevector-port? */
-/* use ftypep */
-
-/* 15.1.? port-open? */
-/* uses ftyped_predp */
-
-/* 15.1.3 with-input-from-file, with-ouput-to-file */
-/* 15.1.? with-error-to-file */
-void with_file(klisp_State *K);
-
-/* 15.1.4 get-current-input-port, get-current-output-port */
-/* 15.1.? get-current-error-port */
-void get_current_port(klisp_State *K);
-
-/* 15.1.5 open-input-file, open-output-file */
-void open_file(klisp_State *K);
-
-/* 15.1.? open-input-string, open-output-string */
-/* 15.1.? open-input-bytevector, open-output-bytevector */
-void open_mport(klisp_State *K);
-
-/* 15.1.6 close-input-file, close-output-file */
-void close_file(klisp_State *K);
-
-/* 15.1.? close-port, close-input-port, close-output-port */
-void close_port(klisp_State *K);
-
-/* 15.1.? get-output-string, get-output-bytevector */
-void get_output_buffer(klisp_State *K);
-
-/* 15.1.7 read */
-void gread(klisp_State *K);
-
-/* 15.1.8 write */
-void gwrite(klisp_State *K);
-
-/* 15.1.? eof-object? */
-/* uses typep */
-
-/* 15.1.? newline */
-void newline(klisp_State *K);
-
-/* 15.1.? write-char */
-void write_char(klisp_State *K);
-
-/* Helper for read-char and peek-char */
-void read_peek_char(klisp_State *K);
-
-/* 15.1.? read-char */
-/* uses read_peek_char */
-
-/* 15.1.? peek-char */
-/* uses read_peek_char */
-
-/* 15.1.? char-ready? */
-/* XXX: this always return #t, proper behaviour requires platform
- specific code (probably select for posix, a thread for windows
- (at least for files & consoles), I think pipes and sockets may
- have something */
-void char_readyp(klisp_State *K);
-
-/* 15.2.1 call-with-input-file, call-with-output-file */
-void call_with_file(klisp_State *K);
-
-/* 15.2.2 load */
-void load(klisp_State *K);
-
-/* 15.2.3 get-module */
-void get_module(klisp_State *K);
-
-/* 15.2.? display */
-void display(klisp_State *K);
-
-void do_close_file_ret(klisp_State *K);
-
-/* 15.1.? flush-output-port */
-void flush(klisp_State *K);
/* init ground */
void kinit_ports_ground_env(klisp_State *K);
diff --git a/src/kgpromises.c b/src/kgpromises.c
@@ -21,6 +21,10 @@
#include "kghelpers.h"
#include "kgpromises.h"
+/* continuations */
+void do_handle_result(klisp_State *K);
+
+
/* SOURCE_NOTE: this is mostly an adaptation of the library derivation
in the report */
diff --git a/src/kgpromises.h b/src/kgpromises.h
@@ -7,30 +7,7 @@
#ifndef kgpromises_h
#define kgpromises_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* 9.1.1 promise? */
-/* uses typep */
-
-/* 9.1.2 force */
-void force(klisp_State *K);
-
-/* 9.1.3 $lazy */
-void Slazy(klisp_State *K);
-
-/* 9.1.4 memoize */
-void memoize(klisp_State *K);
-
-void do_handle_result(klisp_State *K);
/* init ground */
void kinit_promises_ground_env(klisp_State *K);
diff --git a/src/kground.c b/src/kground.c
@@ -65,7 +65,8 @@
void kinit_cont_names(klisp_State *K)
{
Table *t = tv2table(K->cont_name_table);
-
+/* XXX this should be handled like the init_ground_env */
+#if 0
/* REPL, root-continuation & error-continuation */
add_cont_name(K, t, do_root_exit, "exit");
add_cont_name(K, t, do_error_exit, "error");
@@ -109,6 +110,7 @@ void kinit_cont_names(klisp_State *K)
add_cont_name(K, t, do_close_file_ret, "close-file-and-ret");
add_cont_name(K, t, do_handle_result, "handle-result");
add_cont_name(K, t, do_interception, "do-interception");
+#endif
}
/*
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -26,7 +26,6 @@
#include "kghelpers.h"
#include "kgstrings.h"
-#include "kgnumbers.h" /* for keintegerp & knegativep */
/* 13.1.1? string? */
/* uses typep */
@@ -143,10 +142,9 @@ void string_setB(klisp_State *K)
/* GC: Assumes ls is rooted */
TValue list_to_string_h(klisp_State *K, char *name, TValue ls)
{
- int32_t dummy;
/* don't allow cycles */
- int32_t pairs = check_typed_list(K, name, "char", kcharp, false,
- ls, &dummy);
+ int32_t pairs;
+ check_typed_list(K, kcharp, false, ls, &pairs, NULL);
TValue new_str;
/* the if isn't strictly necessary but it's clearer this way */
@@ -376,10 +374,9 @@ void string_append(klisp_State *K)
klisp_assert(ttisenvironment(K->next_env));
UNUSED(xparams);
UNUSED(denv);
- int32_t dummy;
/* don't allow cycles */
- int32_t pairs = check_typed_list(K, "string-append", "string", kstringp,
- false, ptree, &dummy);
+ int32_t pairs;
+ check_typed_list(K, kstringp, false, ptree, &pairs, NULL);
TValue new_str;
int64_t total_size = 0; /* use int64 to check for overflow */
diff --git a/src/kgsymbols.h b/src/kgsymbols.h
@@ -7,34 +7,7 @@
#ifndef kgsymbols_h
#define kgsymbols_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* 4.4.1 symbol? */
-/* uses typep */
-
-/* ?.?.1? symbol->string */
-void symbol_to_string(klisp_State *K);
-
-/* ?.?.2? string->symbol */
-/* TEMP: for now this can create symbols with no external representation
- this includes all symbols with non identifiers characters.
-*/
-/* NOTE:
- Symbols with uppercase alphabetic characters will write as lowercase and
- so, when read again will not compare as either eq? or equal?. This is ok
- because the report only says that read objects when written and read
- again must be equal? which happens here
-*/
-void string_to_symbol(klisp_State *K);
/* init ground */
void kinit_symbols_ground_env(klisp_State *K);
diff --git a/src/kgsystem.h b/src/kgsystem.h
@@ -7,21 +7,7 @@
#ifndef kgsystem_h
#define kgsystem_h
-#include <assert.h>
-#include <stdio.h>
-#include <stdlib.h>
-#include <stdbool.h>
-#include <stdint.h>
-
-#include "kobject.h"
-#include "klisp.h"
#include "kstate.h"
-#include "kghelpers.h"
-
-/* ??.?.? current-second */
-void current_second(klisp_State *K);
-/* ??.?.? current-jiffy */
-void current_jiffy(klisp_State *K);
/* init ground */
void kinit_system_ground_env(klisp_State *K);
diff --git a/src/kgvectors.c b/src/kgvectors.c
@@ -23,7 +23,6 @@
#include "kghelpers.h"
#include "kgvectors.h"
-#include "kgnumbers.h" /* for keintegerp & knegativep */
/* (R7RS 3rd draft 6.3.6) vector? */
/* uses typep */
@@ -135,8 +134,9 @@ void vector_copy(klisp_State *K)
static TValue list_to_vector_h(klisp_State *K, const char *name, TValue ls)
{
- int32_t dummy;
- int32_t pairs = check_list(K, name, false, ls, &dummy);
+ /* don't allow cycles */
+ int32_t pairs;
+ check_list(K, false, ls, &pairs, NULL);
if (pairs == 0) {
return K->empty_vector;
diff --git a/src/klisp.c b/src/klisp.c
@@ -32,12 +32,8 @@
#include "kread.h"
#include "kwrite.h"
#include "kerror.h"
-#include "kghelpers.h" /* for do_return_value */
-#include "kgcontinuations.h" /* for do_pass_value */
-#include "kgcontrol.h" /* for do_seq */
#include "krepl.h"
-
-/* TODO update dependencies in makefile */
+#include "kghelpers.h" /* for do_return_value, do_pass_value and do_seq */
static const char *progname = KLISP_PROGNAME;
diff --git a/src/krepl.c b/src/krepl.c
@@ -19,11 +19,8 @@
#include "ksymbol.h"
#include "kport.h"
#include "kpair.h"
-#include "kgerrors.h"
-/* for names */
-#include "ktable.h"
-/* for do_pass_value */
-#include "kgcontinuations.h"
+#include "ktable.h" /* for names */
+#include "kghelpers.h" /* for do_pass_value */
/* TODO add names & source info to the repl continuations */
diff --git a/src/kstate.c b/src/kstate.c
@@ -37,7 +37,7 @@
#include "kbytevector.h"
#include "kvector.h"
-#include "kgpairs_lists.h" /* for creating list_app */
+#include "kghelpers.h" /* for creating list_app */
#include "kgerrors.h" /* for creating error hierarchy */
#include "kgc.h" /* for memory freeing & gc init */
diff --git a/src/ktable.c b/src/ktable.c
@@ -36,7 +36,7 @@
#include "kstate.h"
#include "ktable.h"
#include "kapplicative.h"
-#include "kgeqp.h"
+#include "kghelpers.h" /* for eq2p */
#include "kstring.h"
/*
