klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

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:
Msrc/Makefile | 6++++--
Asrc/kgpairs_lists.c | 210+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/kgpairs_lists.h | 58++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Msrc/kground.c | 216+------------------------------------------------------------------------------
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 */