summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--srfi/ChangeLog10
-rw-r--r--srfi/srfi-1.c61
-rw-r--r--srfi/srfi-1.h2
-rw-r--r--srfi/srfi-1.scm9
4 files changed, 72 insertions, 10 deletions
diff --git a/srfi/ChangeLog b/srfi/ChangeLog
index f089bed5b..1d77d7747 100644
--- a/srfi/ChangeLog
+++ b/srfi/ChangeLog
@@ -1,3 +1,13 @@
+2006-05-28 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.scm, srfi-1.c, srfi-1.h (append-reverse, append-reverse!):
+ Rewrite in C.
+
+2006-05-20 Kevin Ryde <user42@zip.com.au>
+
+ * srfi-1.c (scm_srfi1_assoc): Correction to comparison procedure
+ argument order, SRFI-1 specifies given key is first.
+
2006-02-06 Marius Vollmer <mvo@zagadka.de>
* srfi-1.scm, srfi-60.scm: Updated versions in library name to
diff --git a/srfi/srfi-1.c b/srfi/srfi-1.c
index a300abfda..8e27ab4e6 100644
--- a/srfi/srfi-1.c
+++ b/srfi/srfi-1.c
@@ -124,6 +124,65 @@ SCM_DEFINE (scm_srfi1_alist_copy, "alist-copy", 1, 0, 0,
#undef FUNC_NAME
+
+SCM_DEFINE (scm_srfi1_append_reverse, "append-reverse", 2, 0, 0,
+ (SCM revhead, SCM tail),
+ "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
+ "result. This is equivalent to @code{(append (reverse\n"
+ "@var{rev-head}) @var{tail})}, but its implementation is more\n"
+ "efficient.\n"
+ "\n"
+ "@example\n"
+ "(append-reverse '(1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
+ "@end example")
+#define FUNC_NAME s_scm_srfi1_append_reverse
+{
+ while (scm_is_pair (revhead))
+ {
+ /* copy first element of revhead onto front of tail */
+ tail = scm_cons (SCM_CAR (revhead), tail);
+ revhead = SCM_CDR (revhead);
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME,
+ "list");
+ return tail;
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_srfi1_append_reverse_x, "append-reverse!", 2, 0, 0,
+ (SCM revhead, SCM tail),
+ "Reverse @var{rev-head}, append @var{tail} to it, and return the\n"
+ "result. This is equivalent to @code{(append! (reverse!\n"
+ "@var{rev-head}) @var{tail})}, but its implementation is more\n"
+ "efficient.\n"
+ "\n"
+ "@example\n"
+ "(append-reverse! (list 1 2 3) '(4 5 6)) @result{} (3 2 1 4 5 6)\n"
+ "@end example\n"
+ "\n"
+ "@var{rev-head} may be modified in order to produce the result.")
+#define FUNC_NAME s_scm_srfi1_append_reverse_x
+{
+ SCM newtail;
+
+ while (scm_is_pair (revhead))
+ {
+ /* take the first cons cell from revhead */
+ newtail = revhead;
+ revhead = SCM_CDR (revhead);
+
+ /* make it the new start of tail, appending the previous */
+ SCM_SETCDR (newtail, tail);
+ tail = newtail;
+ }
+ SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (revhead), revhead, SCM_ARG1, FUNC_NAME,
+ "list");
+ return tail;
+}
+#undef FUNC_NAME
+
+
SCM_DEFINE (scm_srfi1_break, "break", 2, 0, 0,
(SCM pred, SCM lst),
"Return two values, the longest initial prefix of @var{lst}\n"
@@ -1557,7 +1616,7 @@ SCM_DEFINE (scm_srfi1_assoc, "assoc", 2, 1, 0,
SCM tmp = SCM_CAR (ls);
SCM_ASSERT_TYPE (scm_is_pair (tmp), alist, SCM_ARG2, FUNC_NAME,
"association list");
- if (scm_is_true (equal_p (pred, SCM_CAR (tmp), key)))
+ if (scm_is_true (equal_p (pred, key, SCM_CAR (tmp))))
return tmp;
}
SCM_ASSERT_TYPE (SCM_NULL_OR_NIL_P (ls), alist, SCM_ARG2, FUNC_NAME,
diff --git a/srfi/srfi-1.h b/srfi/srfi-1.h
index 810f1046d..936586697 100644
--- a/srfi/srfi-1.h
+++ b/srfi/srfi-1.h
@@ -33,6 +33,8 @@
#endif
SCM_SRFI1_API SCM scm_srfi1_alist_copy (SCM alist);
+SCM_SRFI1_API SCM scm_srfi1_append_reverse (SCM revhead, SCM tail);
+SCM_SRFI1_API SCM scm_srfi1_append_reverse_x (SCM revhead, SCM tail);
SCM_SRFI1_API SCM scm_srfi1_break (SCM pred, SCM lst);
SCM_SRFI1_API SCM scm_srfi1_break_x (SCM pred, SCM lst);
SCM_SRFI1_API SCM scm_srfi1_car_plus_cdr (SCM pair);
diff --git a/srfi/srfi-1.scm b/srfi/srfi-1.scm
index 252e9b312..7c55d9923 100644
--- a/srfi/srfi-1.scm
+++ b/srfi/srfi-1.scm
@@ -324,15 +324,6 @@
;;; Miscelleneous: length, append, concatenate, reverse, zip & count
-(define (append-reverse rev-head tail)
- (let lp ((l rev-head) (acc tail))
- (if (null? l)
- acc
- (lp (cdr l) (cons (car l) acc)))))
-
-(define (append-reverse! rev-head tail)
- (append-reverse rev-head tail)) ; XXX:optimize
-
(define (zip clist1 . rest)
(let lp ((l (cons clist1 rest)) (acc '()))
(if (any null? l)