Commit 044a013b authored by Erick's avatar Erick

Make string-copy R7RS compliant and added R7RS string-copy! function

parent be30c4c6
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 19:36 (eg)
;;;; Last file update: 26-Jun-2018 14:57 (eg)
;;;; Last file update: 28-Jun-2018 10:36 (eg)
;;;;
;;;; ----------------------------------------------------------------------
......@@ -99,6 +99,62 @@ doc>
(%set-procedure-name! string->list 'string->list))
#|
<doc R7RS string-copy!
* (string-copy! to at from)
* (string-copy! to at from start)
* (string-copy! to at from start end)
*
* Copies the characters of |string| from between |start| and |end|
* to string |to|, starting at |at|. The order in which characters are copied
* is unspecified, except that if the source and destination overlap,
* copying takes place as if the source is first copied into a temporary
* string and then into the destination. This can be achieved without
* allocating storage by making sure to copy in the correct direction in
* such circumstances.
*
* It is an error if |at| is less than zero or greater than the length
* of |to|. It is also an error if |(- (string-length to) at)| is less
* than |(- end start)|.
doc>
|#
(define (string-copy! to at from :optional (start 0 start?) (end 0 end?))
(define (err . l)
(apply error 'string-copy! l))
(define (%string-copy! to tstart from fstart fend)
(if (> fstart tstart)
(do ((i fstart (+ i 1))
(j tstart (+ j 1)))
((>= i fend))
(string-set! to j (string-ref from i)))
(do ((i (- fend 1) (- i 1))
(j (+ -1 tstart (- fend fstart)) (- j 1)))
((< i fstart))
(string-set! to j (string-ref from i)))))
;; body starts here
(unless (string? to) (err "bad string ~S" to))
(unless (string? from) (err "bad string ~S" from))
(let ((length-from (string-length from))
(length-to (string-length to)))
(unless (and (integer? at) (>= at 0) (< at length-to))
(err "bad destination index ~S" at))
(when start?
(unless (and (integer? start) (>= start 0) (<= start length-from))
(err "bad integer for start index ~S" start)))
(if end?
(unless (and (integer? end) (>= end 0) (<= end length-from))
(err "bad integer for end index ~S" end))
(set! end (string-length from)))
(when (< (- length-to at) (- end start))
(err "not enough room in destination string ~S" to))
;; do the copy
(with-handler (lambda (x) (err (condition-ref x 'message)))
(%string-copy! to at from start end))))
;;;; ----------------------------------------------------------------------
;;;; 6.8 Vectors
;;;; ----------------------------------------------------------------------
......
......@@ -22,7 +22,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: ??????
* Last file update: 26-Jun-2018 15:23 (eg)
* Last file update: 28-Jun-2018 10:42 (eg)
*/
#include <ctype.h>
......@@ -161,25 +161,25 @@ static SCM control_index(int argc, SCM *argv, int *pstart, int *pend)
case 2: s = argv[0]; start = STk_integer_value(argv[-1]); break;
case 3: s = argv[0]; start = STk_integer_value(argv[-1]);
end = STk_integer_value(argv[-2]); break;
default: STk_error("incorrect number of argument (%d)", argc);
default: STk_error("incorrect number of arguments (%d)", argc);
}
/* Controlling s */
if (!STRINGP(s)) error_bad_string(s);
len = STRING_LENGTH(s);
/* Controling start index */
/* Controlling start index */
if (start == LONG_MIN || start < 0 || start > len)
/* argc cannot be 1 (start would be 0) */
STk_error("bad starting index ~S", argv[(argc==2) ? 0 : -1]);
STk_error("bad starting index ~S", argv[-1]);
/* controling end index */
/* Controlling end index */
if (end == -1)
end = len;
else
if (end == LONG_MIN || end < 0 || end > len)
/* We have an end index ==> argc = 3 */
STk_error("bad ending index ~S", argv[0]);
STk_error("bad ending index ~S", argv[-2]);
if (start > end)
STk_error("low index is greater than high index");
......@@ -232,6 +232,28 @@ static void copy_array(uint32_t *buff, int len, char* from)
from += STk_char2utf8(*buff++, from);
}
static SCM make_substring(SCM string, long from, long to)
{
/* from and to must be checked bay caller */
if (STRING_MONOBYTE(string))
return STk_makestring(to - from, STRING_CHARS(string)+from);
else {
/* multi-bytes string */
uint32_t c;
char *pfrom, *pto;
SCM z;
pto = pfrom = STk_utf8_index(STRING_CHARS(string), from, STRING_SIZE(string));
for ( ; from < to; from++)
pto = STk_utf8_grab_char(pto, &c);
z = STk_makestring(pto - pfrom, pfrom);
STRING_LENGTH(z) = STk_utf8_strlen(STRING_CHARS(z), pto-pfrom);
return z;
}
}
SCM STk_makestring(int len, char *init)
{
......@@ -580,7 +602,7 @@ DEFINE_PRIMITIVE("string-ci>=?", strgei, subr2, (SCM s1, SCM s2))
/*
<doc substring
<doc substring
* (substring string start end)
*
* |String| must be a string, and |start| and |end| must be exact integers
......@@ -593,7 +615,6 @@ DEFINE_PRIMITIVE("string-ci>=?", strgei, subr2, (SCM s1, SCM s2))
* index |end| (exclusive).
doc>
*/
DEFINE_PRIMITIVE("substring", substring, subr3, (SCM string, SCM start, SCM end))
{
long from, to;
......@@ -606,25 +627,9 @@ DEFINE_PRIMITIVE("substring", substring, subr3, (SCM string, SCM start, SCM end)
if (from == LONG_MIN) STk_error("bad lower index ~S", start);
if (to == LONG_MIN) STk_error("bad upper index ~S", end);
if (0 <= from && from <= to && to <= STRING_SIZE(string)) {
if (STRING_MONOBYTE(string))
return STk_makestring(to - from, STRING_CHARS(string)+from);
else {
/* multi-bytes string */
uint32_t c;
char *pfrom, *pto;
SCM z;
pto = pfrom = STk_utf8_index(STRING_CHARS(string), from, STRING_SIZE(string));
for ( ; from < to; from++)
pto = STk_utf8_grab_char(pto, &c);
if (0 <= from && from <= to && to <= STRING_SIZE(string))
return make_substring(string, from, to);
z = STk_makestring(pto - pfrom, pfrom);
STRING_LENGTH(z) = STk_utf8_strlen(STRING_CHARS(z), pto-pfrom);
return z;
}
}
STk_error("index ~S or ~S incorrect", start, end);
return STk_void; /* cannot occur */
}
......@@ -736,16 +741,26 @@ DEFINE_PRIMITIVE("list->string", list2string, subr1, (SCM l))
/*
<doc string-copy
<doc R57RS string-copy
* (string-copy string)
* (string-copy string start)
* (string-copy string start stop)
*
* Returns a newly allocated copy of the given |string|.
doc>
* Returns a newly allocated copy of the part of the given |string|
* between |start| and |stop|.
*
* ,@(bold "Note"): The R5RS version of |string-copy| accepts only one argument.
doc>
*/
DEFINE_PRIMITIVE("string-copy", string_copy, subr1, (SCM str))
DEFINE_PRIMITIVE("string-copy", string_copy, vsubr, (int argc, SCM *argv))
{
if (!STRINGP(str)) error_bad_string(str);
return STk_makestring(STRING_SIZE(str), STRING_CHARS(str));
int start, end;
control_index(argc, argv, &start, &end);
if (start == -1)
return STk_makestring(STRING_SIZE(*argv), STRING_CHARS(*argv));
else
return make_substring(*argv, start, end);
}
......
......@@ -22,7 +22,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 20:58 (eg)
;;;; Last file update: 26-Jun-2018 14:57 (eg)
;;;; Last file update: 28-Jun-2018 10:39 (eg)
;;;;
(require "test")
......@@ -105,7 +105,49 @@
(test "Extended string->list.1" '(#\a #\b #\c #\d #\e #\f) (string->list str))
(test "Extended string->list.2" '(#\c #\d #\e #\f) (string->list str 2))
(test "Extended string->list.3" '(#\c #\d #\e) (string->list str 2 5))
(test "Extended string->list.4" *test-failed* (string->list str 2 100)))
(test "Extended string->list.4" *test-failed* (string->list str 2 100))
(test "Extended string-copy.1" "abcdef" (string-copy str))
(test "Extended string-copy.2" "cdef" (string-copy str 2))
(test "Extended string-copy.3" "cde" (string-copy str 2 5))
(test "Extended string-copy.4" *test-failed* (string-copy str 2 100)))
(test "string-copy!.1"
"abc12f"
(let ((s (string-copy "abcdef"))) (string-copy! s 3 "12") s))
(test "string-copy!.2"
*test-failed*
(let ((s (string-copy "abcdef"))) (string-copy! s 5 "12") s))
(test "string-copy!.3"
"a23def"
(let ((s (string-copy "abcdef"))) (string-copy! s 1 "123" 1) s))
(test "string-copy!.4"
"a23def"
(let ((s (string-copy "abcdef"))) (string-copy! s 1 "123" 1) s))
(test "string-copy!.5"
"a3cdef"
(let ((s (string-copy "abcdef"))) (string-copy! s 1 "123" 2) s))
(test "string-copy!.6"
"abcdef"
(let ((s (string-copy "abcdef"))) (string-copy! s 1 "123" 3) s))
(test "string-copy!.7"
"a12def"
(let ((s (string-copy "abcdef"))) (string-copy! s 1 "123" 0 2) s))
(test "string-copy!.8"
"a123ef"
(let ((s (string-copy "abcdef"))) (string-copy! s 1 "123" 0 3) s))
(test "string-copy!.9"
*test-failed*
(let ((s (string-copy "abcdef"))) (string-copy! s 1 "123" 0 4) s))
(test "string-copy! overlap.1"
"ababcfg"
(let ((s (string-copy "abcdefg"))) (string-copy! s 2 s 0 3) s))
(test "string-copy! overlap.2"
"efcdefg"
(let ((s (string-copy "abcdefg"))) (string-copy! s 0 s 4 6) s))
;;------------------------------------------------------------------
(test-subsection "Lists and Pairs")
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment