commit a31c2af3dc858447c2eec06a8037d0b5d4f963e4
parent 45c79f62417d156d4037f4e764e5e25cc9d69c8a
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sun, 13 Mar 2011 01:57:37 -0300
Extracted out the pairs and lists features from kground.c to a new file kgpairs_lists.c (and .h).
Diffstat:
4 files changed, 273 insertions(+), 217 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -11,7 +11,7 @@ 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 kghelpers.o kgbooleans.o kgeqp.o kgequalp.o \
- kgsymbols.o kgcontrol.o
+ kgsymbols.o kgcontrol.o kgpairs_lists.o
KRN_T= klisp
KRN_O= klisp.o
@@ -68,7 +68,7 @@ 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 kghelpers.h \
- kgbooleans.h kgeqp.h kgequalp.h kgsymbols.h
+ kgbooleans.h kgeqp.h kgequalp.h kgsymbols.h kgpairs_lists.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
kgbooleans.o: kgbooleans.c kgbooleans.c kghelpers.h kstate.h klisp.h \
@@ -81,3 +81,5 @@ kgsymbols.o: kgsymbols.c kgsymbols.c kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kpair.h kcontinuation.h kstring.h
kgcontrol.o: kgcontrol.c kgcontrol.c kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kpair.h kcontinuation.h
+kgpairs_lists.o: kgpairs_lists.c kgpairs_lists.h kghelpers.h kstate.h klisp.h \
+ kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h
diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c
@@ -0,0 +1,210 @@
+/*
+** kgpairs_lists.h
+** Pairs and lists features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#include <assert.h>
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdbool.h>
+#include <stdint.h>
+
+#include "kstate.h"
+#include "kobject.h"
+#include "kpair.h"
+#include "kstring.h"
+#include "kcontinuation.h"
+#include "ksymbol.h"
+#include "kerror.h"
+
+#include "kghelpers.h"
+#include "kgpairs_lists.h"
+
+/* 4.6.1 pair? */
+/* uses typep */
+
+/* 4.6.2 null? */
+/* uses typep */
+
+/* 4.6.3 cons */
+void cons(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+ (void) denv;
+ (void) xparams;
+ bind_2p(K, "cons", ptree, car, cdr);
+
+ TValue new_pair = kcons(K, car, cdr);
+ kapply_cc(K, new_pair);
+}
+
+
+/* 5.2.1 list */
+void list(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+/* the underlying combiner of list return the complete ptree, the only list
+ checking is implicit in the applicative evaluation */
+ (void) xparams;
+ (void) denv;
+ kapply_cc(K, ptree);
+}
+
+/* 5.2.2 list* */
+void listS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+/* TODO:
+ OPTIMIZE: if this call is a result of a call to eval, we could get away
+ with just setting the kcdr of the next to last pair to the car of
+ the last pair, because the list of operands is fresh. Also the type
+ check wouldn't be necessary. This optimization technique could be
+ used in lots of places to avoid checks and the like. */
+ (void) xparams;
+ (void) denv;
+
+ if (ttisnil(ptree)) {
+ klispE_throw(K, "list*: empty argument list");
+ return;
+ }
+ /* GC: should root dummy */
+ TValue dummy = kcons(K, KINERT, KNIL);
+ TValue last_pair = dummy;
+ TValue tail = ptree;
+
+ /* First copy the list, but remembering the next to last pair */
+ while(ttispair(tail) && !kis_marked(tail)) {
+ kmark(tail);
+ /* we save the next_to last pair in the cdr to
+ allow the change into an improper list later */
+ TValue new_pair = kcons(K, kcar(tail), last_pair);
+ kset_cdr(last_pair, new_pair);
+ last_pair = new_pair;
+ tail = kcdr(tail);
+ }
+ unmark_list(K, ptree);
+
+ if (ttisnil(tail)) {
+ /* Now eliminate the last pair to get the correct improper list.
+ This avoids an if in the above loop. It's inside the if because
+ we need at least one pair for this to work. */
+ TValue next_to_last_pair = kcdr(last_pair);
+ kset_cdr(next_to_last_pair, kcar(last_pair));
+ kapply_cc(K, kcdr(dummy));
+ } else if (ttispair(tail)) { /* cyclic argument list */
+ klispE_throw(K, "list*: cyclic argument list");
+ return;
+ } else {
+ klispE_throw(K, "list*: argument list is improper");
+ return;
+ }
+}
+
+/* 5.4.1 car, cdr */
+/* 5.4.2 caar, cadr, ... cddddr */
+
+void c_ad_r( klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
+{
+
+ /*
+ ** xparams[0]: name as symbol
+ ** xparams[1]: an int with the less significant 2 nibbles
+ ** standing for the count and the branch selection.
+ ** The high nibble is the count: that is the number of
+ ** 'a's and 'd's in the name, for example:
+ ** 0x1? for car and cdr.
+ ** 0x2? for caar, cadr, cdar and cddr.
+ ** The low nibble is the branch selection, a 0 bit means
+ ** car, a 1 bit means cdr, the first bit to be applied
+ ** is bit 0 so: caar=0x20, cadr=0x21, cdar:0x22, cddr 0x23
+ */
+
+ char *name = ksymbol_buf(xparams[0]);
+ int p = ivalue(xparams[1]);
+ int count = (p >> 4) & 0xf;
+ int branches = p & 0xf;
+
+ bind_1p(K, name, ptree, obj);
+
+ while(count) {
+ if (!ttispair(obj)) {
+ klispE_throw_extra(K, name, ": non pair found while traversing");
+ return;
+ }
+ obj = ((branches & 1) == 0)? kcar(obj) : kcdr(obj);
+ branches >>= 1;
+ --count;
+ }
+ kapply_cc(K, obj);
+}
+
+/* 5.7.1 get-list-metrics */
+void get_list_metrics(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+ (void) denv;
+ (void) xparams;
+
+ bind_1p(K, "get-list-metrics", ptree, obj);
+ int32_t pairs = 0;
+ TValue tail = obj;
+
+ while(ttispair(tail) && !kis_marked(tail)) {
+ /* record the pair number to simplify cycle pair counting */
+ kset_mark(tail, i2tv(pairs));
+ ++pairs;
+ tail = kcdr(tail);
+ }
+ int32_t apairs, cpairs, nils;
+ if (ttisnil(tail)) {
+ /* simple (possibly empty) list */
+ apairs = pairs;
+ nils = 1;
+ cpairs = 0;
+ } else if (ttispair(tail)) {
+ /* cyclic (maybe circular) list */
+ apairs = ivalue(kget_mark(tail));
+ cpairs = pairs - apairs;
+ nils = 0;
+ } else {
+ apairs = pairs;
+ cpairs = 0;
+ nils = 0;
+ }
+
+ unmark_list(K, obj);
+
+ /* GC: root intermediate pairs */
+ TValue res = kcons(K, i2tv(apairs), kcons(K, i2tv(cpairs), KNIL));
+ res = kcons(K, i2tv(pairs), kcons(K, i2tv(nils), res));
+ kapply_cc(K, res);
+}
+
+/* 5.7.2 list-tail */
+void list_tail(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv)
+{
+/* ASK John: can the object be a cyclic list? the wording of the report
+ seems to indicate that can't be the case, but it makes sense here
+ (cf $encycle!) to allow cyclic lists, so that's what I do */
+ (void) denv;
+ (void) xparams;
+ /* XXX: should be integer instead of fixint, but that's all
+ we have for now */
+ bind_2tp(K, "list-tail", ptree, "any", anytype, obj,
+ "finite integer", ttisfixint, tk);
+ int k = ivalue(tk);
+ if (k < 0) {
+ klispE_throw(K, "list-tail: negative index");
+ return;
+ }
+
+ while(k) {
+ if (!ttispair(obj)) {
+ klispE_throw(K, "list-tail: non pair found while traversing "
+ "object");
+ return;
+ }
+ obj = kcdr(obj);
+ --k;
+ }
+ kapply_cc(K, obj);
+}
diff --git a/src/kgpairs_lists.h b/src/kgpairs_lists.h
@@ -0,0 +1,58 @@
+/*
+** kgpairs_lists.h
+** Pairs and lists features for the ground environment
+** See Copyright Notice in klisp.h
+*/
+
+#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, TValue *xparams, TValue ptree, TValue denv);
+
+/* 5.2.1 list */
+void list(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* 5.2.2 list* */
+void listS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* 5.4.1 car, cdr */
+/* 5.4.2 caar, cadr, ... cddddr */
+void c_ad_r( klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
+
+/* 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, TValue *xparams, TValue ptree,
+ TValue denv);
+
+/* 5.7.2 list-tail */
+void list_tail(klisp_State *K, TValue *xparams, TValue ptree,
+ TValue denv);
+
+#endif
diff --git a/src/kground.c b/src/kground.c
@@ -28,6 +28,7 @@
#include "kgequalp.h"
#include "kgsymbols.h"
#include "kgcontrol.h"
+#include "kgpairs_lists.h"
/*
** This section will roughly follow the report and will reference the
@@ -36,27 +37,6 @@
/* TODO: split in different files for each module */
/*
-** 4.6 Pairs and lists
-*/
-
-/* 4.6.1 pair? */
-/* uses typep */
-
-/* 4.6.2 null? */
-/* uses typep */
-
-/* 4.6.3 cons */
-void cons(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
-{
- (void) denv;
- (void) xparams;
- bind_2p(K, "cons", ptree, car, cdr);
-
- TValue new_pair = kcons(K, car, cdr);
- kapply_cc(K, new_pair);
-}
-
-/*
** 4.7 Pair mutation
*/
@@ -587,69 +567,6 @@ void unwrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
*/
/*
-** 5.2 Pairs and lists
-*/
-
-/* 5.2.1 list */
-/* the underlying combiner of list return the complete ptree, the only list
- checking is implicit in the applicative evaluation */
-void list(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
-{
- (void) xparams;
- (void) denv;
- kapply_cc(K, ptree);
-}
-
-/* 5.2.2 list* */
-/* TODO:
- OPTIMIZE: if this call is a result of a call to eval, we could get away
- with just setting the kcdr of the next to last pair to the car of
- the last pair, because the list of operands is fresh. Also the type
- check wouldn't be necessary. This optimization technique could be
- used in lots of places to avoid checks and the like. */
-void listS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
-{
- (void) xparams;
- (void) denv;
-
- if (ttisnil(ptree)) {
- klispE_throw(K, "list*: empty argument list");
- return;
- }
- /* GC: should root dummy */
- TValue dummy = kcons(K, KINERT, KNIL);
- TValue last_pair = dummy;
- TValue tail = ptree;
-
- /* First copy the list, but remembering the next to last pair */
- while(ttispair(tail) && !kis_marked(tail)) {
- kmark(tail);
- /* we save the next_to last pair in the cdr to
- allow the change into an improper list later */
- TValue new_pair = kcons(K, kcar(tail), last_pair);
- kset_cdr(last_pair, new_pair);
- last_pair = new_pair;
- tail = kcdr(tail);
- }
- unmark_list(K, ptree);
-
- if (ttisnil(tail)) {
- /* Now eliminate the last pair to get the correct improper list.
- This avoids an if in the above loop. It's inside the if because
- we need at least one pair for this to work. */
- TValue next_to_last_pair = kcdr(last_pair);
- kset_cdr(next_to_last_pair, kcar(last_pair));
- kapply_cc(K, kcdr(dummy));
- } else if (ttispair(tail)) { /* cyclic argument list */
- klispE_throw(K, "list*: cyclic argument list");
- return;
- } else {
- klispE_throw(K, "list*: argument list is improper");
- return;
- }
-}
-
-/*
** 5.3 Combiners
*/
@@ -673,60 +590,6 @@ void Slambda(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/*
-** 5.4 Pairs and lists
-*/
-
-/* 5.4.1 car, cdr */
-/* 5.4.2 caar, cadr, ... cddddr */
-
-/* Helper macros to construct xparams[1] */
-#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))
-
-/* the name stands for the regular expression c[ad]{1,4}r */
-void c_ad_r( klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
-{
-
- /*
- ** xparams[0]: name as symbol
- ** xparams[1]: an int with the less significant 2 nibbles
- ** standing for the count and the branch selection.
- ** The high nibble is the count: that is the number of
- ** 'a's and 'd's in the name, for example:
- ** 0x1? for car and cdr.
- ** 0x2? for caar, cadr, cdar and cddr.
- ** The low nibble is the branch selection, a 0 bit means
- ** car, a 1 bit means cdr, the first bit to be applied
- ** is bit 0 so: caar=0x20, cadr=0x21, cdar:0x22, cddr 0x23
- */
-
- char *name = ksymbol_buf(xparams[0]);
- int p = ivalue(xparams[1]);
- int count = (p >> 4) & 0xf;
- int branches = p & 0xf;
-
- bind_1p(K, name, ptree, obj);
-
- while(count) {
- if (!ttispair(obj)) {
- klispE_throw_extra(K, name, ": non pair found while traversing");
- return;
- }
- obj = ((branches & 1) == 0)? kcar(obj) : kcdr(obj);
- branches >>= 1;
- --count;
- }
- kapply_cc(K, obj);
-}
-
-
-/*
** 5.5 Combiners
*/
@@ -761,83 +624,6 @@ void apply(klisp_State *K, TValue *xparams, TValue ptree,
}
/*
-** 5.7 Pairs and lists
-*/
-
-/* 5.7.1 get-list-metrics */
-void get_list_metrics(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
-{
- (void) denv;
- (void) xparams;
-
- bind_1p(K, "get-list-metrics", ptree, obj);
- int32_t pairs = 0;
- TValue tail = obj;
-
- while(ttispair(tail) && !kis_marked(tail)) {
- /* record the pair number to simplify cycle pair counting */
- kset_mark(tail, i2tv(pairs));
- ++pairs;
- tail = kcdr(tail);
- }
- int32_t apairs, cpairs, nils;
- if (ttisnil(tail)) {
- /* simple (possibly empty) list */
- apairs = pairs;
- nils = 1;
- cpairs = 0;
- } else if (ttispair(tail)) {
- /* cyclic (maybe circular) list */
- apairs = ivalue(kget_mark(tail));
- cpairs = pairs - apairs;
- nils = 0;
- } else {
- apairs = pairs;
- cpairs = 0;
- nils = 0;
- }
-
- unmark_list(K, obj);
-
- /* GC: root intermediate pairs */
- TValue res = kcons(K, i2tv(apairs), kcons(K, i2tv(cpairs), KNIL));
- res = kcons(K, i2tv(pairs), kcons(K, i2tv(nils), res));
- kapply_cc(K, res);
-}
-
-/* 5.7.2 list-tail */
-/* ASK John: can the object be a cyclic list? the wording of the report
- seems to indicate that can't be the case, but it makes sense here
- (cf $encycle!) to allow cyclic lists, so that's what I do */
-void list_tail(klisp_State *K, TValue *xparams, TValue ptree,
- TValue denv)
-{
- (void) denv;
- (void) xparams;
- /* XXX: should be integer instead of fixint, but that's all
- we have for now */
- bind_2tp(K, "list-tail", ptree, "any", anytype, obj,
- "finite integer", ttisfixint, tk);
- int k = ivalue(tk);
- if (k < 0) {
- klispE_throw(K, "list-tail: negative index");
- return;
- }
-
- while(k) {
- if (!ttispair(obj)) {
- klispE_throw(K, "list-tail: non pair found while traversing "
- "object");
- return;
- }
- obj = kcdr(obj);
- --k;
- }
- kapply_cc(K, obj);
-}
-
-/*
** 5.8 Pair mutation
*/
