From 4be12cb2c072d9210c599b0b9fedbdfa1cc84759 Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@users.sourceforge.net>
Date: Fri, 21 May 2010 11:24:17 +0200
Subject: [PATCH] New C functions for copy-seq and subseq

---
 src/c/sequence.d   | 93 +++++++++++++++++++++-------------------------
 src/cmp/sysfun.lsp |  2 +
 src/h/external.h   |  2 +
 3 files changed, 47 insertions(+), 50 deletions(-)

diff --git a/src/c/sequence.d b/src/c/sequence.d
index 43d648496..1c19d04b4 100644
--- a/src/c/sequence.d
+++ b/src/c/sequence.d
@@ -142,73 +142,66 @@ E:
 	FEtype_error_index(seq, MAKE_FIXNUM(index));
 }
 
-@(defun subseq (sequence start &optional end &aux x)
-	cl_fixnum s, e;
-	cl_fixnum i;
-@
-	s = fixnnint(start);
-	if (Null(end))
-		e = -1;
-	else
-		e = fixnnint(end);
+cl_object
+ecl_subseq(cl_object sequence, cl_index start, cl_index limit)
+{
 	switch (type_of(sequence)) {
 	case t_list:
-		if (Null(sequence)) {
-			if (s > 0)
-				goto ILLEGAL_START_END;
-			if (e > 0)
-				goto ILLEGAL_START_END;
-			@(return Cnil)
+		if (start)
+			sequence = ecl_nthcdr(start, sequence);
+		{
+			cl_object x = Cnil;
+			cl_object *z = &x;
+			while (!Null(sequence) && (limit--)) {
+				if (ECL_ATOM(sequence))
+					FEtype_error_cons(sequence);
+				z = &ECL_CONS_CDR(*z = ecl_list1(ECL_CONS_CAR(sequence)));
+				sequence = ECL_CONS_CDR(sequence);
+			}
+			return x;
 		}
-		if (e >= 0)
-			if ((e -= s) < 0)
-				goto ILLEGAL_START_END;
-		while (s-- > 0) {
-			if (ATOM(sequence))
-				goto ILLEGAL_START_END;
-			sequence = CDR(sequence);
-		}
-		if (e < 0)
-			return cl_copy_list(sequence);
-		{ cl_object *z = &x;
-		  for (i = 0;  i < e;  i++) {
-		    if (ATOM(sequence))
-		      goto ILLEGAL_START_END;
-		    z = &ECL_CONS_CDR(*z = ecl_list1(CAR(sequence)));
-		    sequence = CDR(sequence);
-		  }
-		}
-		@(return x)
-
 #ifdef ECL_UNICODE
 	case t_string:
 #endif
 	case t_vector:
 	case t_bitvector:
-	case t_base_string:
-		if (s > sequence->vector.fillp)
-			goto ILLEGAL_START_END;
-		if (e < 0)
-			e = sequence->vector.fillp;
-		else if (e < s || e > sequence->vector.fillp)
-			goto ILLEGAL_START_END;
-		x = ecl_alloc_simple_vector(e - s, ecl_array_elttype(sequence));
-		ecl_copy_subarray(x, 0, sequence, s, e-s);
-		@(return x)
-
+	case t_base_string: {
+		cl_index size;
+		cl_object x;
+		if (start > sequence->vector.fillp) {
+			x = ecl_alloc_simple_vector(0, ecl_array_elttype(sequence));
+		} else {
+			size = sequence->vector.fillp - start;
+			if (size > limit)
+				size = limit;
+			x = ecl_alloc_simple_vector(size, ecl_array_elttype(sequence));
+			ecl_copy_subarray(x, 0, sequence, start, size);
+		}
+		return x;
+	}
 	default:
 		FEtype_error_sequence(sequence);
 	}
+}
 
-ILLEGAL_START_END:
-	FEerror("~S and ~S are illegal as :START and :END~%\
-for the sequence ~S.", 3, start, end, sequence);
+cl_object
+ecl_copy_seq(cl_object sequence)
+{
+	return ecl_subseq(sequence, 0, MOST_POSITIVE_FIXNUM);
+}
+
+@(defun subseq (sequence start &optional end &aux x)
+	cl_index_pair p;
+@
+	p = ecl_sequence_start_end(@[subseq], sequence, start, end);
+	sequence = ecl_subseq(sequence, p.start, p.end - p.start);
+	@(return sequence);
 @)
 
 cl_object
 cl_copy_seq(cl_object x)
 {
-	return @subseq(2, x, MAKE_FIXNUM(0));
+	@(return ecl_subseq(x, 0, MOST_POSITIVE_FIXNUM));
 }
 
 cl_object
diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp
index 20174b6d7..6bec15587 100644
--- a/src/cmp/sysfun.lsp
+++ b/src/cmp/sysfun.lsp
@@ -708,6 +708,8 @@
 (def-inline length :always (t) :fixnum "ecl_length(#0)")
 (def-inline length :unsafe (vector) :fixnum "(#0)->vector.fillp")
 
+(def-inline copy-seq :always (t) t "ecl_copy_seq(#0)")
+
 ;; file character.d
 
 (def-inline char :always (t fixnum) t "ecl_aref1(#0,#1)")
diff --git a/src/h/external.h b/src/h/external.h
index 1bc7f7222..2493c058d 100755
--- a/src/h/external.h
+++ b/src/h/external.h
@@ -1489,6 +1489,8 @@ extern ECL_API cl_object cl_subseq _ARGS((cl_narg narg, cl_object sequence, cl_o
 extern ECL_API cl_object ecl_elt(cl_object seq, cl_fixnum index);
 extern ECL_API cl_object ecl_elt_set(cl_object seq, cl_fixnum index, cl_object val);
 extern ECL_API cl_fixnum ecl_length(cl_object x);
+extern ECL_API cl_object ecl_subseq(cl_object seq, cl_index start, cl_index limit);
+extern ECL_API cl_object ecl_copy_seq(cl_object seq);
 
 
 /* stacks.c */