Commit f5fbab50 authored by Erick's avatar Erick

Extended the string-fill! function to be R7RS

parent 044a013b
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 19:36 (eg)
;;;; Last file update: 28-Jun-2018 10:36 (eg)
;;;; Last file update: 28-Jun-2018 17:27 (eg)
;;;;
;;;; ----------------------------------------------------------------------
......@@ -63,25 +63,17 @@ doc>
;; Set the name of the new function to the old one for better error messages
(%set-procedure-name! ,func ',func)))
(%generalize-string-compare string=? string2=?)
(%generalize-string-compare string<? string2<?)
(%generalize-string-compare string<=? string2<=?)
(%generalize-string-compare string>? string2>?)
(%generalize-string-compare string>=? string2>=?)
(%generalize-string-compare string-ci=? string-ci2=?)
(%generalize-string-compare string-ci<? string-ci2<?)
(%generalize-string-compare string-ci<=? string-ci2<=?)
(%generalize-string-compare string-ci>? string-ci2>?)
(%generalize-string-compare string-ci>=? string-ci2>=?)
(define (s->l s :optional (start 0 start?) (end 0 end?))
(if (or start? end?)
(let ((end (if end? end (string-length s))))
(with-handler (lambda (x)
(error 'string->list (condition-ref x 'message)))
(string->list (substring s start end))))
(string->list s)))
(%generalize-string-compare string=? %string2=?)
(%generalize-string-compare string<? %string2<?)
(%generalize-string-compare string<=? %string2<=?)
(%generalize-string-compare string>? %string2>?)
(%generalize-string-compare string>=? %string2>=?)
(%generalize-string-compare string-ci=? %string-ci2=?)
(%generalize-string-compare string-ci<? %string-ci2<?)
(%generalize-string-compare string-ci<=? %string-ci2<=?)
(%generalize-string-compare string-ci>? %string-ci2>?)
(%generalize-string-compare string-ci>=? %string-ci2>=?)
;;
;; Generalized string->list
......@@ -100,7 +92,7 @@ doc>
#|
<doc R7RS string-copy!
<doc R7RS string-copy!
* (string-copy! to at from)
* (string-copy! to at from start)
* (string-copy! to at from start end)
......@@ -112,7 +104,7 @@ doc>
* 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)|.
......@@ -155,6 +147,32 @@ doc>
(with-handler (lambda (x) (err (condition-ref x 'message)))
(%string-copy! to at from start end))))
;;
;; R7RS string-fill!
;;
; Keep the R5RS version available
(define %string-fill2! string-fill!)
;; Implement the one with 2 to 4 parameters
(let ((fill (lambda (str char :optional (start 0 start?) (end 0 end?))
(with-handler (lambda (x) (error 'string-fill! (condition-ref x 'message)))
(if start?
;; R7RS string-fill!
(begin
(unless end?
(set! end (string-length str)))
(let Loop ((i start))
(when (< i end)
(string-set! str i char)
(Loop (+ i 1)))))
;; R5RS string-fill!
(%string-fill2! str char))))))
(set! string-fill! fill)
(%set-procedure-name! string-fill! 'string-fill!))
;;;; ----------------------------------------------------------------------
;;;; 6.8 Vectors
;;;; ----------------------------------------------------------------------
......
This diff is collapsed.
This diff is collapsed.
......@@ -22,7 +22,7 @@
*
* Author: Erick Gallesio [eg@unice.fr]
* Creation date: ??????
* Last file update: 28-Jun-2018 10:42 (eg)
* Last file update: 28-Jun-2018 17:01 (eg)
*/
#include <ctype.h>
......@@ -767,12 +767,20 @@ DEFINE_PRIMITIVE("string-copy", string_copy, vsubr, (int argc, SCM *argv))
/*
<doc EXT string-fill!
* (string-fill! string char)
* (string-fill! string char start)
* (string-fill! string char start end)
*
* Stores |char| in every element of the given |string| and returns ,(emph "void").
* Stores |char| in every element of the given |string| between |start| and |end|.
*
* ,@(bold "Note"): The R5RS version of |string-fill!| accepts only one argument.
doc>
*/
DEFINE_PRIMITIVE("string-fill!", string_fill, subr2, (SCM str, SCM c))
{
/*
* The following function implements the R5RS version of string-fill!
* The R7RS version is written in Scheme in file r7rs.stk.
*/
int bytes, len, c_char, c_len;
char *s;
......
......@@ -22,7 +22,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 20:58 (eg)
;;;; Last file update: 28-Jun-2018 10:39 (eg)
;;;; Last file update: 28-Jun-2018 17:36 (eg)
;;;;
(require "test")
......@@ -144,11 +144,25 @@
(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 "string-fill!.1"
"abcde"
(let ((x (string-copy "abcde"))) (string-fill! x #\1 2 2) x))
(test "string-fill!.2"
"ab11e"
(let ((x (string-copy "abcde"))) (string-fill! x #\1 2 4) x))
(test "string-fill!.2"
"ab111"
(let ((x (string-copy "abcde"))) (string-fill! x #\1 2 5) x))
(test "string-fill!.3"
*test-failed*
(let ((x (string-copy "abcde"))) (string-fill! x #\1 2 6) x))
;;------------------------------------------------------------------
(test-subsection "Lists and Pairs")
......
......@@ -21,7 +21,7 @@
;;;;
;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 27-May-2011 23:35 (eg)
;;;; Last file update: 15-Jun-2018 19:41 (eg)
;;;; Last file update: 28-Jun-2018 17:47 (eg)
;;;;
(require "test")
......@@ -248,6 +248,17 @@
(unless *is-C?*
(test "string-fill! with char of different lengths.1"
" λλλλλ "
(let ((x (make-string 7 #\space)))
(string-fill! x #\λ 1 6)
x))
(test "string-fill! with char of different lengths.2"
"λ λ"
(let ((x (make-string 7 #\λ)))
(string-fill! x #\space 1 6)
x))
;;---- Test the lambda form with λ symbol
(test "lambda symbol.1"
'(1 2 3)
......
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