commit 9bde851711b37bca2efd775d6d5d37015d152413
parent 931c6e55e070fe1c9a1de58a5d564988d6f38e7a
Author: Andres Navarro <canavarro82@gmail.com>
Date: Fri, 25 Nov 2011 14:29:48 -0300
Added list-set! to the ground environment. Added tests for list-set!. Refactored some functions to kghelpers
Diffstat:
9 files changed, 175 insertions(+), 83 deletions(-)
diff --git a/TODO b/TODO
@@ -30,7 +30,6 @@
** $named-let (r7rs)
** $do (r7rs)
* applicatives:
-** list-set! (r7rs)
** vector-map (r7rs)
** bytevector-map (r7rs)
** char-foldcase (r7rs)
diff --git a/src/Makefile b/src/Makefile
@@ -185,7 +185,8 @@ kgffi.o: kgffi.c imath.h kobject.h klimits.h klisp.h klispconf.h kstate.h \
kgcombiners.h kgcontinuations.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
+ 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 kghelpers.h kenvironment.h ksymbol.h kstring.h kgchars.h
@@ -209,7 +210,7 @@ kgpair_mut.o: kgpair_mut.c kstate.h klimits.h klisp.h kobject.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 kinteger.h imath.h
+ koperative.h kgequalp.h kgpairs_lists.h kgnumbers.h imath.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 \
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -16,6 +16,7 @@
#include "klisp.h"
#include "kerror.h"
#include "ksymbol.h"
+#include "kinteger.h"
void typep(klisp_State *K)
{
@@ -383,3 +384,76 @@ int64_t klcm32_64(int32_t a_, int32_t b_)
/* divide first to avoid possible overflow */
return (a / gcd) * b;
}
+
+/* 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)
+{
+ TValue tail = obj;
+ int32_t pairs = 0;
+
+ 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);
+
+ if (p != NULL) *p = pairs;
+ if (n != NULL) *n = nils;
+ if (a != NULL) *a = apairs;
+ if (c != NULL) *c = cpairs;
+}
+
+/* Helper for list-tail, list-ref and list-set! */
+/* Calculate the smallest i such that
+ (eq? (list-tail obj i) (list-tail obj tk))
+ 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 apairs, cpairs;
+ get_list_metrics_aux(K, obj, NULL, NULL, &apairs, &cpairs);
+ if (cpairs == 0) {
+ klispE_throw_simple(K, "non pair found while traversing "
+ "object");
+ return 0;
+ }
+ TValue tv_apairs = i2tv(apairs);
+ TValue tv_cpairs = i2tv(cpairs);
+
+ /* all calculations will be done with bigints */
+ kensure_bigint(tv_apairs);
+ kensure_bigint(tv_cpairs);
+
+ TValue idx = kbigint_minus(K, tk, tv_apairs);
+ krooted_tvs_push(K, idx); /* root idx if it is a bigint */
+ /* idx may have become a fixint */
+ kensure_bigint(idx);
+ UNUSED(kbigint_div_mod(K, idx, tv_cpairs, &idx));
+ krooted_tvs_pop(K);
+ /* now idx is less than cpairs so it fits in a fixint */
+ assert(ttisfixint(idx));
+ return ivalue(idx) + apairs;
+}
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -430,6 +430,18 @@ inline int32_t kcheck32(klisp_State *K, char *msg, int64_t i)
int64_t kgcd32_64(int32_t a, int32_t b);
int64_t klcm32_64(int32_t a, int32_t b);
+/*
+** Other
+*/
+
+/* Helper for list-tail, list-ref and list-set! */
+int32_t ksmallest_index(klisp_State *K, char *name, 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);
/*
** Macros for ground environment initialization
diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c
@@ -264,9 +264,53 @@ void encycleB(klisp_State *K)
kapply_cc(K, KINERT);
}
-/* Helpers for append! */
+/* 6.?? list-set! */
+void list_setB(klisp_State *K)
+{
+ TValue *xparams = K->next_xparams;
+ TValue ptree = K->next_value;
+ TValue denv = K->next_env;
+ klisp_assert(ttisenvironment(K->next_env));
+/* ASK John: can the object be an improper list?
+ We foolow list-tail here and allow it */
+ UNUSED(denv);
+ UNUSED(xparams);
+
+ bind_3tp(K, ptree, "any", anytype, obj,
+ "exact integer", keintegerp, tk,
+ "any", anytype, val);
+
+ if (knegativep(tk)) {
+ klispE_throw_simple(K, "negative index");
+ return;
+ }
+
+ int32_t k = (ttisfixint(tk))? ivalue(tk)
+ : ksmallest_index(K, "list-set!", obj, tk);
+ while(k) {
+ if (!ttispair(obj)) {
+ klispE_throw_simple(K, "non pair found while traversing "
+ "object");
+ return;
+ }
+ obj = kcdr(obj);
+ --k;
+ }
+ if (!ttispair(obj)) {
+ klispE_throw_simple(K, "non pair found while traversing "
+ "object");
+ } else if (kis_immutable(obj)) {
+ /* this could be checked before, but the error here seems better */
+ klispE_throw_simple(K, "immutable pair");
+ } else {
+ kset_car(obj, val);
+ kapply_cc(K, KINERT);
+ }
+}
+
+/* Helpers for append! */
inline void appendB_clear_last_pairs(klisp_State *K, TValue ls)
{
UNUSED(K);
@@ -536,6 +580,8 @@ void kinit_pair_mut_ground_env(klisp_State *K)
b2tv(false));
/* 5.8.1 encycle! */
add_applicative(K, ground_env, "encycle!", encycleB, 0);
+ /* 6.?? list-set! */
+ add_applicative(K, ground_env, "list-set!", list_setB, 0);
/* 6.4.1 append! */
add_applicative(K, ground_env, "append!", appendB, 0);
/* 6.4.2 copy-es */
diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c
@@ -23,7 +23,6 @@
#include "kgequalp.h"
#include "kgpairs_lists.h"
#include "kgnumbers.h"
-#include "kinteger.h"
/* 4.6.1 pair? */
/* uses typep */
@@ -235,46 +234,6 @@ void reverse(klisp_State *K)
}
}
-
-/* also used in list-tail and list-ref 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)
-{
- TValue tail = obj;
- int32_t pairs = 0;
-
- 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);
-
- if (p != NULL) *p = pairs;
- if (n != NULL) *n = nils;
- if (a != NULL) *a = apairs;
- if (c != NULL) *c = cpairs;
-}
-
/* 5.7.1 get-list-metrics */
void get_list_metrics(klisp_State *K)
{
@@ -295,42 +254,6 @@ void get_list_metrics(klisp_State *K)
kapply_cc(K, res);
}
-/* Helper for list-tail and list-ref */
-
-/* Calculate the smallest i such that
- (eq? (list-tail obj i) (list-tail obj tk))
- 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 apairs, cpairs;
- get_list_metrics_aux(K, obj, NULL, NULL, &apairs, &cpairs);
- if (cpairs == 0) {
- klispE_throw_simple(K, "non pair found while traversing "
- "object");
- return 0;
- }
- TValue tv_apairs = i2tv(apairs);
- TValue tv_cpairs = i2tv(cpairs);
-
- /* all calculations will be done with bigints */
- kensure_bigint(tv_apairs);
- kensure_bigint(tv_cpairs);
-
- TValue idx = kbigint_minus(K, tk, tv_apairs);
- krooted_tvs_push(K, idx); /* root idx if it is a bigint */
- /* idx may have become a fixint */
- kensure_bigint(idx);
- UNUSED(kbigint_div_mod(K, idx, tv_cpairs, &idx));
- krooted_tvs_pop(K);
- /* now idx is less than cpairs so it fits in a fixint */
- assert(ttisfixint(idx));
- return ivalue(idx) + apairs;
-}
-
-
/* 5.7.2 list-tail */
void list_tail(klisp_State *K)
{
diff --git a/src/kpair.h b/src/kpair.h
@@ -61,7 +61,6 @@ inline TValue kcdr(TValue p)
#define kcdddar(p_) (kcdr(kcdr(kcdr(kcar(p_)))))
#define kcddddr(p_) (kcdr(kcdr(kcdr(kcdr(p_)))))
-/* these will also work with immutable pairs */
inline void kset_car(TValue p, TValue v)
{
klisp_assert(kmutable_pairp(p));
diff --git a/src/tests/pair-mutation.k b/src/tests/pair-mutation.k
@@ -35,7 +35,29 @@
($check equal? ($let ((l (list* 1 2 3 4 5))) (encycle! l 0 3) l)
(list . #0=(1 2 3 . #0#)))
+;; list-set!
+($check-predicate (inert? (list-set! (list 0 1 2 3) 0 10)))
+($check equal? ($let ((l (list 0 1 2 3)))
+ (list-set! l 1 10)
+ (list-set! l 3 30)
+ l)
+ (list 0 10 2 30))
+($check equal? ($let ((l (list 0 . #1=(1 2 . #1#))))
+ (list-set! l 1 10)
+ (list-set! l 4 20)
+ l)
+ (list 0 . #2=(10 20 . #2#)))
+;; see kgpair_mut.c for rationale on allowing
+;; improper lists as argument to list-set!
+($check equal? ($let ((l (list* 0 1 2 3)))
+ (list-set! l 1 10)
+ (list-set! l 2 20)
+ l)
+ (list* 0 10 20 3))
+
;; append!
+($check-predicate (inert? (append! (list 1) (list 2))))
+
($let ()
($define! l1 (list 1 2))
($define! l2 (list 3 4))
@@ -159,6 +181,19 @@
($check-error (encycle! (list 1 2 3) 0 -2))
($check-error (encycle! (list 1 2 3) 0 #e+infinity))
+;; list-set!
+;; set-car! & set-cdr!
+($check-error (list-set!))
+($check-error (list-set! (list 1)))
+($check-error (list-set! (list 1) 0))
+($check-error (list-set! (list 1) 0 1 1))
+
+($check-error (list-set! #inert 0 0))
+($check-error (list-set! () 0 0))
+($check-error (list-set! (list 1 2) 2 0))
+($check-error (list-set! (list 1 2) -1 0))
+($check-error (list-set! (list* 1 2 3) 2 0))
+
;; append!
;; ASK does the report assert that the lists remains unmodified??
;; probably should for robust implementations
diff --git a/src/tests/pairs-and-lists.k b/src/tests/pairs-and-lists.k
@@ -172,7 +172,7 @@
;; list-ref
($check =? (list-ref (list 1 2 3 4 5) 0) 1)
($check =? (list-ref (list 1 2 3 4 5) 1) 2)
-;; see ground/pairs-and-lists.scm for rationale on allowing
+;; see kgpairs_lists.c for rationale on allowing
;; improper lists as argument to list-ref
($check =? (list-ref (list* 1 2 3 4) 2) 3)
($check =? (list-ref (list . #0=(1 2 3 4 5 . #0#)) 10) 1)
@@ -377,6 +377,9 @@
($check-error (make-list))
($check-error (make-list "str"))
($check-error (make-list 1 "str" "str2"))
+($check-error (make-list -2))
+($check-error (make-list 3/4))
+($check-error (make-list #e+infinity))
;; list-copy
($check-error (list-copy))
