klisp

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

commit b65f6cb7e2f5d9057506a943373af15afed5323c
parent a31c2af3dc858447c2eec06a8037d0b5d4f963e4
Author: Andres Navarro <canavarro82@gmail.com>
Date:   Sun, 13 Mar 2011 02:09:00 -0300

Extracted out the pair mutation features from kground.c to a new file kgpair_mut.c (and .h).

Diffstat:
Msrc/Makefile | 4+++-
Asrc/kgpair_mut.c | 211+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asrc/kgpair_mut.h | 37+++++++++++++++++++++++++++++++++++++
Msrc/kgpairs_lists.c | 2+-
Msrc/kground.c | 205+------------------------------------------------------------------------------
5 files changed, 253 insertions(+), 206 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 kgpairs_lists.o + kgsymbols.o kgcontrol.o kgpairs_lists.o kgpair_mut.o KRN_T= klisp KRN_O= klisp.o @@ -83,3 +83,5 @@ 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 +kgpair_mut.o: kgpair_mut.c kgpair_mut.h kghelpers.h kstate.h klisp.h \ + kobject.h kerror.h kpair.h ksymbol.h kcontinuation.h diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c @@ -0,0 +1,211 @@ +/* +** kgpair_mut.c +** Pair mutation 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 "kcontinuation.h" +#include "ksymbol.h" +#include "kerror.h" + +#include "kghelpers.h" +#include "kgpair_mut.h" + +/* 4.7.1 set-car!, set-cdr! */ +void set_carB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) +{ + (void) denv; + (void) xparams; + bind_2tp(K, "set-car!", ptree, "pair", ttispair, pair, + "any", anytype, new_car); + + if(!kis_mutable(pair)) { + klispE_throw(K, "set-car!: immutable pair"); + return; + } + kset_car(pair, new_car); + kapply_cc(K, KINERT); +} + +void set_cdrB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) +{ + (void) denv; + (void) xparams; + bind_2tp(K, "set-cdr!", ptree, "pair", ttispair, pair, + "any", anytype, new_cdr); + + if(!kis_mutable(pair)) { + klispE_throw(K, "set-cdr!: immutable pair"); + return; + } + kset_cdr(pair, new_cdr); + kapply_cc(K, KINERT); +} + +/* 4.7.2 copy-es-immutable */ +void copy_es_immutable(klisp_State *K, TValue *xparams, + TValue ptree, TValue denv) +{ + /* + ** xparams[0]: copy-es-immutable symbol + */ + char *name = ksymbol_buf(xparams[0]); + bind_1p(K, name, ptree, obj); + + TValue copy = copy_es_immutable_h(K, name, obj); + kapply_cc(K, copy); +} + +/* +** 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 +*/ +TValue copy_es_immutable_h(klisp_State *K, char *name, TValue obj) +{ + /* + ** GC: obj is rooted because it is in the stack at all times. + ** The copied pair should be kept safe some other way + */ + TValue copy = obj; + + 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 (ttispair(top) && kis_mutable(top)) { + if (kis_marked(top)) { + /* this pair was already seen, use the same */ + copy = kget_mark(top); + } else { + TValue new_pair = kdummy_imm_cons(K); + kset_mark(top, new_pair); + /* 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) { + kset_car(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 { + kset_cdr(new_pair, copy); + copy = new_pair; + } + } + } + unmark_tree(K, obj); + return copy; +} + +/* 5.8.1 encycle! */ +void encycleB(klisp_State *K, TValue *xparams, TValue ptree, + TValue denv) +{ +/* ASK John: can the object be a cyclic list of length less than k1+k2? + the wording of the report seems to indicate that can't be the case, + and here it makes sense to forbid it because otherwise the list-metrics + of the result would differ with the expected ones (cf list-tail). + So here an error is signaled if the improper list cyclic with less pairs + than needed */ + (void) denv; + (void) xparams; + /* XXX: should be integer instead of fixint, but that's all + we have for now */ + bind_3tp(K, "encycle!", ptree, "any", anytype, obj, + "finite integer", ttisfixint, tk1, + "finite integer", ttisfixint, tk2); + + int32_t k1 = ivalue(tk1); + int32_t k2 = ivalue(tk2); + + if (k1 < 0 || k2 < 0) { + klispE_throw(K, "encycle!: negative index"); + return; + } + + TValue tail = obj; + + while(k1) { + if (!ttispair(tail)) { + unmark_list(K, obj); + klispE_throw(K, "encycle!: non pair found while traversing " + "object"); + return; + } else if (kis_marked(tail)) { + unmark_list(K, obj); + klispE_throw(K, "encycle!: too few pairs in cyclic list"); + return; + } + kmark(tail); + tail = kcdr(tail); + --k1; + } + + TValue fcp = tail; + + /* if k2 == 0 do nothing (but this still checks that the obj + has at least k1 pairs */ + if (k2 != 0) { + --k2; /* to have cycle length k2 we should discard k2-1 pairs */ + while(k2) { + if (!ttispair(tail)) { + unmark_list(K, obj); + klispE_throw(K, "encycle!: non pair found while traversing " + "object"); + return; + } else if (kis_marked(tail)) { + unmark_list(K, obj); + klispE_throw(K, "encycle!: too few pairs in cyclic list"); + return; + } + kmark(tail); + tail = kcdr(tail); + --k2; + } + if (!kis_mutable(tail)) { + unmark_list(K, obj); + klispE_throw(K, "encycle!: immutable pair"); + return; + } else { + kset_cdr(tail, fcp); + } + } + unmark_list(K, obj); + kapply_cc(K, KINERT); +} diff --git a/src/kgpair_mut.h b/src/kgpair_mut.h @@ -0,0 +1,37 @@ +/* +** kgpair_mut.h +** Pair mutation features for the ground environment +** See Copyright Notice in klisp.h +*/ + +#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); + +/* 4.7.1 set-car!, set-cdr! */ +void set_carB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv); + +void set_cdrB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv); + +/* 4.7.2 copy-es-immutable */ +void copy_es_immutable(klisp_State *K, TValue *xparams, + TValue ptree, TValue denv); + +/* 5.8.1 encycle! */ +void encycleB(klisp_State *K, TValue *xparams, TValue ptree, + TValue denv); + +#endif diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c @@ -1,5 +1,5 @@ /* -** kgpairs_lists.h +** kgpairs_lists.c ** Pairs and lists features for the ground environment ** See Copyright Notice in klisp.h */ diff --git a/src/kground.c b/src/kground.c @@ -29,6 +29,7 @@ #include "kgsymbols.h" #include "kgcontrol.h" #include "kgpairs_lists.h" +#include "kgpair_mut.h" /* ** This section will roughly follow the report and will reference the @@ -37,129 +38,6 @@ /* TODO: split in different files for each module */ /* -** 4.7 Pair mutation -*/ - -/* 4.7.1 set-car!, set-cdr! */ -void set_carB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) -{ - (void) denv; - (void) xparams; - bind_2tp(K, "set-car!", ptree, "pair", ttispair, pair, - "any", anytype, new_car); - - if(!kis_mutable(pair)) { - klispE_throw(K, "set-car!: immutable pair"); - return; - } - kset_car(pair, new_car); - kapply_cc(K, KINERT); -} - -void set_cdrB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv) -{ - (void) denv; - (void) xparams; - bind_2tp(K, "set-cdr!", ptree, "pair", ttispair, pair, - "any", anytype, new_cdr); - - if(!kis_mutable(pair)) { - klispE_throw(K, "set-cdr!: immutable pair"); - return; - } - kset_cdr(pair, new_cdr); - kapply_cc(K, KINERT); -} - -/* 4.7.2 copy-es-immutable */ - -/* Helper (also used by $vau, $lambda, etc) */ -TValue copy_es_immutable_h(klisp_State *K, char *name, TValue ptree); - -void copy_es_immutable(klisp_State *K, TValue *xparams, - TValue ptree, TValue denv) -{ - /* - ** xparams[0]: copy-es-immutable symbol - */ - char *name = ksymbol_buf(xparams[0]); - bind_1p(K, name, ptree, obj); - - TValue copy = copy_es_immutable_h(K, name, obj); - kapply_cc(K, copy); -} - -/* -** 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 -*/ - -TValue copy_es_immutable_h(klisp_State *K, char *name, TValue obj) -{ - /* - ** GC: obj is rooted because it is in the stack at all times. - ** The copied pair should be kept safe some other way - */ - TValue copy = obj; - - 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 (ttispair(top) && kis_mutable(top)) { - if (kis_marked(top)) { - /* this pair was already seen, use the same */ - copy = kget_mark(top); - } else { - TValue new_pair = kdummy_imm_cons(K); - kset_mark(top, new_pair); - /* 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) { - kset_car(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 { - kset_cdr(new_pair, copy); - copy = new_pair; - } - } - } - unmark_tree(K, obj); - return copy; -} - - -/* ** 4.8 Environments */ @@ -624,87 +502,6 @@ void apply(klisp_State *K, TValue *xparams, TValue ptree, } /* -** 5.8 Pair mutation -*/ - -/* 5.8.1 encycle! */ -/* ASK John: can the object be a cyclic list of length less than k1+k2? - the wording of the report seems to indicate that can't be the case, - and here it makes sense to forbid it because otherwise the list-metrics - of the result would differ with the expected ones (cf list-tail). - So here an error is signaled if the improper list cyclic with less pairs - than needed */ -void encycleB(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_3tp(K, "encycle!", ptree, "any", anytype, obj, - "finite integer", ttisfixint, tk1, - "finite integer", ttisfixint, tk2); - - int32_t k1 = ivalue(tk1); - int32_t k2 = ivalue(tk2); - - if (k1 < 0 || k2 < 0) { - klispE_throw(K, "encycle!: negative index"); - return; - } - - TValue tail = obj; - - while(k1) { - if (!ttispair(tail)) { - unmark_list(K, obj); - klispE_throw(K, "encycle!: non pair found while traversing " - "object"); - return; - } else if (kis_marked(tail)) { - unmark_list(K, obj); - klispE_throw(K, "encycle!: too few pairs in cyclic list"); - return; - } - kmark(tail); - tail = kcdr(tail); - --k1; - } - - TValue fcp = tail; - - /* if k2 == 0 do nothing (but this still checks that the obj - has at least k1 pairs */ - if (k2 != 0) { - --k2; /* to have cycle length k2 we should discard k2-1 pairs */ - while(k2) { - if (!ttispair(tail)) { - unmark_list(K, obj); - klispE_throw(K, "encycle!: non pair found while traversing " - "object"); - return; - } else if (kis_marked(tail)) { - unmark_list(K, obj); - klispE_throw(K, "encycle!: too few pairs in cyclic list"); - return; - } - kmark(tail); - tail = kcdr(tail); - --k2; - } - if (!kis_mutable(tail)) { - unmark_list(K, obj); - klispE_throw(K, "encycle!: immutable pair"); - return; - } else { - kset_cdr(tail, fcp); - } - } - unmark_list(K, obj); - kapply_cc(K, KINERT); -} - -/* ** 5.9 Combiners */