commit 77a6cd56698fe6ee7ec75b1b0b6191440783a667
parent f4f179f0c7b0d2c914dd53cebf2332488454b28f
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sat, 12 Mar 2011 22:47:49 -0300
Extracted out the ground helpers to a new file kghelpers.c (and .h).
Diffstat:
| M | src/Makefile | | | 8 | +++++--- |
| A | src/kghelpers.c | | | 49 | +++++++++++++++++++++++++++++++++++++++++++++++++ |
| A | src/kghelpers.h | | | 257 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | src/kground.c | | | 295 | ++++++------------------------------------------------------------------------- |
4 files changed, 332 insertions(+), 277 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -10,7 +10,7 @@ MYLIBS=
CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kwrite.o kstate.o kmem.o kerror.o kauxlib.o kenvironment.o \
kcontinuation.o koperative.o kapplicative.o keval.o krepl.o \
- kground.o
+ kground.o kghelpers.o
KRN_T= klisp
KRN_O= klisp.o
@@ -66,4 +66,6 @@ keval.o: keval.c keval.h kcontinuation.h kenvironment.h kstate.h kobject.h \
krepl.o: krepl.c krepl.h kcontinuation.h kstate.h kobject.h keval.h klisp.h \
kread.h kwrite.h kenvironment.h
kground.o: kground.c kground.h kstate.h kobject.h klisp.h kenvironment.h \
- kpair.h kapplicative.h koperative.h ksymbol.h kerror.h
-\ No newline at end of file
+ kpair.h kapplicative.h koperative.h ksymbol.h kerror.h kghelpers.h
+kghelpers.o: kghelpers.c kghelpers.h kstate.h kstate.h klisp.h kpair.h \
+ kapplicative.h koperative.h kerror.h kobject.h ksymbol.h
+\ No newline at end of file
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -0,0 +1,49 @@
+/*
+** kghelpers.c
+** Helper macros and functions for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#include <assert.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kghelpers.h"
+#include "kstate.h"
+#include "kobject.h"
+#include "klisp.h"
+#include "kerror.h"
+#include "ksymbol.h"
+
+void typep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ (void) denv;
+ /*
+ ** xparams[0]: name symbol
+ ** xparams[1]: type tag (as by i2tv)
+ */
+ int32_t tag = ivalue(xparams[1]);
+
+ /* 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 &= ttype(kcar(tail)) == tag;
+ tail = kcdr(tail);
+ }
+ unmark_list(K, ptree);
+
+ if (ttispair(tail) || ttisnil(tail)) {
+ kapply_cc(K, b2tv(res));
+ } else {
+ char *name = ksymbol_buf(xparams[0]);
+ klispE_throw_extra(K, name, ": expected list");
+ return;
+ }
+}
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -0,0 +1,257 @@
+/*
+** kghelpers.h
+** Helper macros and functions for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#ifndef kghelpers_h
+#define kghelpers_h
+
+#include <assert.h>
+#include <stdlib.h>
+#include <stdio.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kstate.h"
+#include "kobject.h"
+#include "klisp.h"
+#include "kerror.h"
+#include "kpair.h"
+#include "kapplicative.h"
+#include "koperative.h"
+
+/* to use in type checking binds when no check is needed */
+#define anytype(obj_) (true)
+
+/*
+** 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
+** their arguments more than once
+*/
+#define bind_1p(K_, n_, ptree_, v_) \
+ bind_1tp(K_, n_, ptree_, "any", anytype, v_)
+
+#define bind_1tp(K_, n_, ptree_, tstr_, t_, v_) \
+ TValue v_; \
+ if (!ttispair(ptree_) || !ttisnil(kcdr(ptree_))) { \
+ klispE_throw_extra(K_, n_ , ": Bad ptree (expected one argument)"); \
+ return; \
+ } \
+ v_ = kcar(ptree_); \
+ if (!t_(v_)) { \
+ klispE_throw_extra(K_, n_ , ": Bad type on first argument " \
+ "(expected " tstr_ ")"); \
+ return; \
+ }
+
+
+#define bind_2p(K_, n_, ptree_, v1_, v2_) \
+ bind_2tp(K_, n_, ptree_, "any", anytype, v1_, "any", anytype, v2_)
+
+#define bind_2tp(K_, n_, ptree_, tstr1_, t1_, v1_, \
+ tstr2_, t2_, v2_) \
+ TValue v1_, v2_; \
+ if (!ttispair(ptree_) || !ttispair(kcdr(ptree_)) || \
+ !ttisnil(kcddr(ptree_))) { \
+ klispE_throw_extra(K_, n_ , ": Bad ptree (expected two arguments)"); \
+ return; \
+ } \
+ v1_ = kcar(ptree_); \
+ v2_ = kcadr(ptree_); \
+ if (!t1_(v1_)) { \
+ klispE_throw_extra(K_, n_, ": Bad type on first argument (expected " \
+ tstr1_ ")"); \
+ return; \
+ } else if (!t2_(v2_)) { \
+ klispE_throw_extra(K_, n_, ": Bad type on second argument (expected " \
+ tstr2_ ")"); \
+ return; \
+ }
+
+#define bind_3p(K_, n_, ptree_, v1_, v2_, v3_) \
+ bind_3tp(K_, n_, ptree_, "any", anytype, v1_, \
+ "any", anytype, v2_, "any", anytype, v3_)
+
+#define bind_3tp(K_, n_, ptree_, tstr1_, t1_, v1_, \
+ tstr2_, t2_, v2_, tstr3_, t3_, v3_) \
+ TValue v1_, v2_, v3_; \
+ if (!ttispair(ptree_) || !ttispair(kcdr(ptree_)) || \
+ !ttispair(kcddr (ptree_)) || !ttisnil(kcdddr(ptree_))) { \
+ klispE_throw_extra(K_, n_, ": Bad ptree (expected three arguments)"); \
+ return; \
+ } \
+ v1_ = kcar(ptree_); \
+ v2_ = kcadr(ptree_); \
+ v3_ = kcaddr(ptree_); \
+ if (!t1_(v1_)) { \
+ klispE_throw_extra(K_, n_, ": Bad type on first argument (expected " \
+ tstr1_ ")"); \
+ return; \
+ } else if (!t2_(v2_)) { \
+ klispE_throw_extra(K_, n_, ": Bad type on second argument (expected " \
+ tstr2_ ")"); \
+ return; \
+ } else if (!t3_(v3_)) { \
+ klispE_throw_extra(K_, n_, ": Bad type on third argument (expected " \
+ tstr3_ ")"); \
+ return; \
+ }
+
+
+/* bind at least 2 parameters, like (v1_ v2_ . v3_) */
+#define bind_al2p(K_, n_, ptree_, v1_, v2_, v3_) \
+ TValue v1_, v2_, v3_; \
+ if (!ttispair(ptree_) || !ttispair(kcdr(ptree_))) { \
+ klispE_throw_extra(K_, n_, ": Bad ptree (expected at least 2 " \
+ "arguments)"); \
+ return; \
+ } \
+ v1_ = kcar(ptree_); \
+ v2_ = kcadr(ptree_); \
+ v3_ = kcddr(ptree_)
+
+/* TODO: add name and source info */
+#define make_operative(K_, fn_, ...) \
+ kmake_operative(K_, KNIL, KNIL, fn_, __VA_ARGS__)
+#define make_applicative(K_, fn_, ...) \
+ kwrap(K_, kmake_operative(K_, KNIL, KNIL, fn_, __VA_ARGS__))
+
+
+#endif
+
+/*
+** This states are useful for traversing trees, saving the state in the
+** token char buffer
+*/
+#define ST_PUSH ((char) 0)
+#define ST_CAR ((char) 1)
+#define ST_CDR ((char) 2)
+
+/*
+** Unmarking structures.
+** These two stop at the first object that is not a marked pair
+*/
+inline void unmark_list(klisp_State *K, TValue obj)
+{
+ (void) K; /* not needed, it's here for consistency */
+ while(ttispair(obj) && kis_marked(obj)) {
+ kunmark(obj);
+ obj = kcdr(obj);
+ }
+}
+
+inline void unmark_tree(klisp_State *K, TValue obj)
+{
+ assert(ks_sisempty(K));
+
+ ks_spush(K, obj);
+
+ while(!ks_sisempty(K)) {
+ obj = ks_spop(K);
+
+ if (ttispair(obj) && kis_marked(obj)) {
+ kunmark(obj);
+ ks_spush(K, kcdr(obj));
+ ks_spush(K, kcar(obj));
+ }
+ }
+}
+
+/*
+** Structure checking and copying
+*/
+
+/* check that obj is a list, returns the number of pairs */
+inline int32_t check_list(klisp_State *K, char *name, TValue obj)
+{
+ TValue tail = obj;
+ int pairs = 0;
+ while(ttispair(tail) && !kis_marked(tail)) {
+ kmark(tail);
+ tail = kcdr(tail);
+ ++pairs;
+ }
+ unmark_list(K, obj);
+
+ if (!ttispair(tail) && !ttisnil(tail)) {
+ klispE_throw_extra(K, name , ": expected list");
+ return 0;
+ }
+ return pairs;
+}
+
+/* check that obj is a list and make a copy if it is not immutable */
+inline TValue check_copy_list(klisp_State *K, char *name, TValue obj)
+{
+ if (ttisnil(obj))
+ return obj;
+
+ if (ttispair(obj) && kis_immutable(obj)) {
+ (void)check_list(K, name, obj);
+ return obj;
+ } else {
+ TValue dummy = kcons(K, KINERT, KNIL);
+ TValue last_pair = dummy;
+ 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);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ tail = kcdr(tail);
+ }
+
+ if (ttispair(tail)) {
+ /* complete the cycle */
+ kset_cdr(last_pair, kget_mark(tail));
+ }
+
+ unmark_list(K, obj);
+
+ if (!ttispair(tail) && !ttisnil(tail)) {
+ klispE_throw_extra(K, name , ": expected list");
+ return KINERT;
+ }
+ return kcdr(dummy);
+ }
+}
+
+/* check that obj is a list of environments and make a copy but don't keep
+ the cycles */
+inline TValue check_copy_env_list(klisp_State *K, char *name, TValue obj)
+{
+ TValue dummy = kcons(K, KINERT, KNIL);
+ TValue last_pair = dummy;
+ TValue tail = obj;
+
+ while(ttispair(tail) && !kis_marked(tail)) {
+ TValue first = kcar(tail);
+ if (!ttisenvironment(first)) {
+ klispE_throw_extra(K, name, ": 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_extra(K, name , ": expected list");
+ return KINERT;
+ }
+ return kcdr(dummy);
+}
+
+/*
+** This is a generic function for type predicates
+** It can only be used by types that have a unique tag
+*/
+void typep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
diff --git a/src/kground.c b/src/kground.c
@@ -4,9 +4,11 @@
** See Copyright Notice in klisp.h
*/
-/* TODO: split in different files for each module */
-
#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
#include "kstate.h"
#include "kobject.h"
@@ -20,283 +22,13 @@
#include "kapplicative.h"
#include "kerror.h"
-/*
-** Some helper macros and functions
-*/
-#define anytype(obj_) (true)
-
-/*
-** 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
-** their arguments more than once
-*/
-#define bind_1p(K_, n_, ptree_, v_) \
- bind_1tp(K_, n_, ptree_, "any", anytype, v_)
-
-#define bind_1tp(K_, n_, ptree_, tstr_, t_, v_) \
- TValue v_; \
- if (!ttispair(ptree_) || !ttisnil(kcdr(ptree_))) { \
- klispE_throw_extra(K_, n_ , ": Bad ptree (expected one argument)"); \
- return; \
- } \
- v_ = kcar(ptree_); \
- if (!t_(v_)) { \
- klispE_throw_extra(K_, n_ , ": Bad type on first argument " \
- "(expected " tstr_ ")"); \
- return; \
- }
-
-
-#define bind_2p(K_, n_, ptree_, v1_, v2_) \
- bind_2tp(K_, n_, ptree_, "any", anytype, v1_, "any", anytype, v2_)
-
-#define bind_2tp(K_, n_, ptree_, tstr1_, t1_, v1_, \
- tstr2_, t2_, v2_) \
- TValue v1_, v2_; \
- if (!ttispair(ptree_) || !ttispair(kcdr(ptree_)) || \
- !ttisnil(kcddr(ptree_))) { \
- klispE_throw_extra(K_, n_ , ": Bad ptree (expected two arguments)"); \
- return; \
- } \
- v1_ = kcar(ptree_); \
- v2_ = kcadr(ptree_); \
- if (!t1_(v1_)) { \
- klispE_throw_extra(K_, n_, ": Bad type on first argument (expected " \
- tstr1_ ")"); \
- return; \
- } else if (!t2_(v2_)) { \
- klispE_throw_extra(K_, n_, ": Bad type on second argument (expected " \
- tstr2_ ")"); \
- return; \
- }
-
-#define bind_3p(K_, n_, ptree_, v1_, v2_, v3_) \
- bind_3tp(K_, n_, ptree_, "any", anytype, v1_, \
- "any", anytype, v2_, "any", anytype, v3_)
-
-#define bind_3tp(K_, n_, ptree_, tstr1_, t1_, v1_, \
- tstr2_, t2_, v2_, tstr3_, t3_, v3_) \
- TValue v1_, v2_, v3_; \
- if (!ttispair(ptree_) || !ttispair(kcdr(ptree_)) || \
- !ttispair(kcddr (ptree_)) || !ttisnil(kcdddr(ptree_))) { \
- klispE_throw_extra(K_, n_, ": Bad ptree (expected three arguments)"); \
- return; \
- } \
- v1_ = kcar(ptree_); \
- v2_ = kcadr(ptree_); \
- v3_ = kcaddr(ptree_); \
- if (!t1_(v1_)) { \
- klispE_throw_extra(K_, n_, ": Bad type on first argument (expected " \
- tstr1_ ")"); \
- return; \
- } else if (!t2_(v2_)) { \
- klispE_throw_extra(K_, n_, ": Bad type on second argument (expected " \
- tstr2_ ")"); \
- return; \
- } else if (!t3_(v3_)) { \
- klispE_throw_extra(K_, n_, ": Bad type on third argument (expected " \
- tstr3_ ")"); \
- return; \
- }
-
-
-/* bind at least 2 parameters, like (v1_ v2_ . v3_) */
-#define bind_al2p(K_, n_, ptree_, v1_, v2_, v3_) \
- TValue v1_, v2_, v3_; \
- if (!ttispair(ptree_) || !ttispair(kcdr(ptree_))) { \
- klispE_throw_extra(K_, n_, ": Bad ptree (expected at least 2 " \
- "arguments)"); \
- return; \
- } \
- v1_ = kcar(ptree_); \
- v2_ = kcadr(ptree_); \
- v3_ = kcddr(ptree_)
-
-/* TODO: add name and source info */
-#define make_operative(K_, fn_, ...) \
- kmake_operative(K_, KNIL, KNIL, fn_, __VA_ARGS__)
-#define make_applicative(K_, fn_, ...) \
- kwrap(K_, kmake_operative(K_, KNIL, KNIL, fn_, __VA_ARGS__))
-
-/*
-** BEWARE: this is highly unhygienic, it assumes variables "symbol" and
-** "value", both of type TValue. symbol will be bound to a symbol named by
-** "n_" and can be referrenced in the var_args
-*/
-#define add_operative(K_, env_, n_, fn_, ...) \
- { symbol = ksymbol_new(K_, n_); \
- value = make_operative(K_, fn_, __VA_ARGS__); \
- kadd_binding(K_, env_, symbol, value); }
-
-#define add_applicative(K_, env_, n_, fn_, ...) \
- { symbol = ksymbol_new(K_, n_); \
- value = make_applicative(K_, fn_, __VA_ARGS__); \
- kadd_binding(K_, env_, symbol, value); }
-
-/*
-** This states are useful for traversing trees, saving the state in the
-** token char buffer
-*/
-#define ST_PUSH ((char) 0)
-#define ST_CAR ((char) 1)
-#define ST_CDR ((char) 2)
-
-/*
-** These two stop at the first object that is not a marked pair
-*/
-inline void unmark_list(klisp_State *K, TValue obj)
-{
- (void) K; /* not needed, it's here for consistency */
- while(ttispair(obj) && kis_marked(obj)) {
- kunmark(obj);
- obj = kcdr(obj);
- }
-}
-
-inline void unmark_tree(klisp_State *K, TValue obj)
-{
- assert(ks_sisempty(K));
-
- ks_spush(K, obj);
-
- while(!ks_sisempty(K)) {
- obj = ks_spop(K);
-
- if (ttispair(obj) && kis_marked(obj)) {
- kunmark(obj);
- ks_spush(K, kcdr(obj));
- ks_spush(K, kcar(obj));
- }
- }
-}
-
-/* check that obj is a list, returns the number of pairs */
-inline int32_t check_list(klisp_State *K, char *name, TValue obj)
-{
- TValue tail = obj;
- int pairs = 0;
- while(ttispair(tail) && !kis_marked(tail)) {
- kmark(tail);
- tail = kcdr(tail);
- ++pairs;
- }
- unmark_list(K, obj);
-
- if (!ttispair(tail) && !ttisnil(tail)) {
- klispE_throw_extra(K, name , ": expected list");
- return 0;
- }
- return pairs;
-}
-
-/* check that obj is a list and make a copy if it is not immutable */
-inline TValue check_copy_list(klisp_State *K, char *name, TValue obj)
-{
- if (ttisnil(obj))
- return obj;
-
- if (ttispair(obj) && kis_immutable(obj)) {
- (void)check_list(K, name, obj);
- return obj;
- } else {
- TValue dummy = kcons(K, KINERT, KNIL);
- TValue last_pair = dummy;
- 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);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- tail = kcdr(tail);
- }
-
- if (ttispair(tail)) {
- /* complete the cycle */
- kset_cdr(last_pair, kget_mark(tail));
- }
-
- unmark_list(K, obj);
-
- if (!ttispair(tail) && !ttisnil(tail)) {
- klispE_throw_extra(K, name , ": expected list");
- return KINERT;
- }
- return kcdr(dummy);
- }
-}
-
-/* check that obj is a list of environments and make a copy but don't keep
- the cycles */
-inline TValue check_copy_env_list(klisp_State *K, char *name, TValue obj)
-{
- TValue dummy = kcons(K, KINERT, KNIL);
- TValue last_pair = dummy;
- TValue tail = obj;
-
- while(ttispair(tail) && !kis_marked(tail)) {
- TValue first = kcar(tail);
- if (!ttisenvironment(first)) {
- klispE_throw_extra(K, name, ": 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_extra(K, name , ": expected list");
- return KINERT;
- }
- return kcdr(dummy);
-}
-
-/*
-** This is a generic function for type predicates
-** It can only be used by types that have a unique tag
-*/
-void typep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
-{
- (void) denv;
- /*
- ** xparams[0]: name symbol
- ** xparams[1]: type tag (as by i2tv)
- */
- int32_t tag = ivalue(xparams[1]);
-
- /* 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 &= ttype(kcar(tail)) == tag;
- tail = kcdr(tail);
- }
- unmark_list(K, ptree);
-
- if (ttispair(tail) || ttisnil(tail)) {
- kapply_cc(K, b2tv(res));
- } else {
- char *name = ksymbol_buf(xparams[0]);
- klispE_throw_extra(K, name, ": expected list");
- return;
- }
-}
+#include "kghelpers.h"
/*
** This section will roughly follow the report and will reference the
** section in which each symbol is defined
*/
+/* TODO: split in different files for each module */
/*
**
@@ -1522,6 +1254,21 @@ void encycleB(klisp_State *K, TValue *xparams, TValue ptree,
/* TODO */
/*
+** BEWARE: this is highly unhygienic, it assumes variables "symbol" and
+** "value", both of type TValue. symbol will be bound to a symbol named by
+** "n_" and can be referrenced in the var_args
+*/
+#define add_operative(K_, env_, n_, fn_, ...) \
+ { symbol = ksymbol_new(K_, n_); \
+ value = make_operative(K_, fn_, __VA_ARGS__); \
+ kadd_binding(K_, env_, symbol, value); }
+
+#define add_applicative(K_, env_, n_, fn_, ...) \
+ { symbol = ksymbol_new(K_, n_); \
+ value = make_applicative(K_, fn_, __VA_ARGS__); \
+ kadd_binding(K_, env_, symbol, value); }
+
+/*
** This is called once to bind all symbols in the ground environment
*/
TValue kmake_ground_env(klisp_State *K)
