Commit be30c4c6 authored by Erick's avatar Erick

Extended the string->list function to be R7RS compliant

parent 34484e47
...@@ -21,7 +21,7 @@ ...@@ -21,7 +21,7 @@
;;;; ;;;;
;;;; Author: Erick Gallesio [eg@unice.fr] ;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 19:36 (eg) ;;;; Creation date: 17-Apr-2011 19:36 (eg)
;;;; Last file update: 26-Jun-2018 14:41 (eg) ;;;; Last file update: 26-Jun-2018 14:57 (eg)
;;;; ;;;;
;;;; ---------------------------------------------------------------------- ;;;; ----------------------------------------------------------------------
...@@ -45,6 +45,9 @@ doc> ...@@ -45,6 +45,9 @@ doc>
;;;; 6.7 Strings ;;;; 6.7 Strings
;;;; ---------------------------------------------------------------------- ;;;; ----------------------------------------------------------------------
;;
;; Generalized string comparison functions
;;
(define-macro (%generalize-string-compare func func2) (define-macro (%generalize-string-compare func func2)
`(begin `(begin
;; Keep the old function since it is twice faster than the general one ;; Keep the old function since it is twice faster than the general one
...@@ -72,7 +75,6 @@ doc> ...@@ -72,7 +75,6 @@ doc>
(%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?)) (define (s->l s :optional (start 0 start?) (end 0 end?))
(if (or start? end?) (if (or start? end?)
(let ((end (if end? end (string-length s)))) (let ((end (if end? end (string-length s))))
...@@ -81,6 +83,22 @@ doc> ...@@ -81,6 +83,22 @@ doc>
(string->list (substring s start end)))) (string->list (substring s start end))))
(string->list s))) (string->list s)))
;;
;; Generalized string->list
;;
(let ((s->l string->list)) ;; s->l is the R5RS function
(set! string->list
(lambda (str :optional (start 0 start?) (end 0 end?))
(if (or start? end?)
(let ((end (if end? end (string-length str))))
(with-handler (lambda (x)
(error 'string->list
(condition-ref x 'message)))
(s->l (substring str start end))))
(s->l str))))
(%set-procedure-name! string->list 'string->list))
;;;; ---------------------------------------------------------------------- ;;;; ----------------------------------------------------------------------
;;;; 6.8 Vectors ;;;; 6.8 Vectors
;;;; ---------------------------------------------------------------------- ;;;; ----------------------------------------------------------------------
......
...@@ -22,7 +22,7 @@ ...@@ -22,7 +22,7 @@
* *
* Author: Erick Gallesio [eg@unice.fr] * Author: Erick Gallesio [eg@unice.fr]
* Creation date: ?????? * Creation date: ??????
* Last file update: 26-Jun-2018 11:50 (eg) * Last file update: 26-Jun-2018 15:23 (eg)
*/ */
#include <ctype.h> #include <ctype.h>
...@@ -518,7 +518,7 @@ DEFINE_PRIMITIVE("string-set!", string_set, subr3, (SCM str, SCM index, SCM valu ...@@ -518,7 +518,7 @@ DEFINE_PRIMITIVE("string-set!", string_set, subr3, (SCM str, SCM index, SCM valu
* characters in the same positions, otherwise returns |#f|. |String-ci=?| * characters in the same positions, otherwise returns |#f|. |String-ci=?|
* treats upper and lower case letters as though they were the same character, * treats upper and lower case letters as though they were the same character,
* but |string=?| treats upper and lower case as distinct characters. * but |string=?| treats upper and lower case as distinct characters.
* *
* ,@(bold "Note"): R5RS version of these functions accept only two arguments. * ,@(bold "Note"): R5RS version of these functions accept only two arguments.
doc> doc>
*/ */
...@@ -668,15 +668,20 @@ DEFINE_PRIMITIVE("string-append", string_append, vsubr, (int argc, SCM* argv)) ...@@ -668,15 +668,20 @@ DEFINE_PRIMITIVE("string-append", string_append, vsubr, (int argc, SCM* argv))
/* /*
<doc string->list list->string <doc R57RS string->list list->string
* (string->list string) * (string->list string)
* (string->list string start)
* (string->list string start end)
* (list->string list) * (list->string list)
* *
* |String->list| returns a newly allocated list of the characters that make * |String->list| returns a newly allocated list of the characters of
* up the given string. |List->string| returns a newly allocated string * |string| between |start| and |end|. |List->string| returns a newly
* formed from the characters in the list |list|, which must be a list of * allocated string formed from the characters in the list |list|,
* characters. |String->list| and |list->string| are inverses so far as * which must be a list of characters. |String->list| and
* |equal?| is concerned. * |list->string| are inverses so far as |equal?| is concerned.
*
* ,@("Note"): The R5RS version of |string->list| accepts only one
* parameter.
doc> doc>
*/ */
DEFINE_PRIMITIVE("string->list", string2list, subr1, (SCM str)) DEFINE_PRIMITIVE("string->list", string2list, subr1, (SCM str))
...@@ -952,7 +957,7 @@ DEFINE_PRIMITIVE("string-mutable?", string_mutable, subr1, (SCM obj)) ...@@ -952,7 +957,7 @@ DEFINE_PRIMITIVE("string-mutable?", string_mutable, subr1, (SCM obj))
* (string-downcase "Foo BAR" 4) => "bar" * (string-downcase "Foo BAR" 4) => "bar"
* (string-downcase "Foo BAR" 4 6) => "ba" * (string-downcase "Foo BAR" 4 6) => "ba"
* @end lisp * @end lisp
* *
* ,@(bold "Note"): In R7RS, |string-downcase| accepts only one argument. * ,@(bold "Note"): In R7RS, |string-downcase| accepts only one argument.
doc> doc>
*/ */
...@@ -1056,7 +1061,7 @@ DEFINE_PRIMITIVE("string-downcase!", string_ddowncase, vsubr, (int argc, SCM *ar ...@@ -1056,7 +1061,7 @@ DEFINE_PRIMITIVE("string-downcase!", string_ddowncase, vsubr, (int argc, SCM *ar
* |start| and |end| indices have been replaced by their upper case equivalent. * |start| and |end| indices have been replaced by their upper case equivalent.
* If |start| is omited, it defaults to 0. If |end| is omited, it defaults to * If |start| is omited, it defaults to 0. If |end| is omited, it defaults to
* the length of |str|. * the length of |str|.
* *
* ,@(bold "Note"): In R7RS, |string-upcase| accepts only one argument. * ,@(bold "Note"): In R7RS, |string-upcase| accepts only one argument.
doc> doc>
*/ */
......
...@@ -22,7 +22,7 @@ ...@@ -22,7 +22,7 @@
;;;; ;;;;
;;;; Author: Erick Gallesio [eg@unice.fr] ;;;; Author: Erick Gallesio [eg@unice.fr]
;;;; Creation date: 17-Apr-2011 20:58 (eg) ;;;; Creation date: 17-Apr-2011 20:58 (eg)
;;;; Last file update: 26-Jun-2018 11:58 (eg) ;;;; Last file update: 26-Jun-2018 14:57 (eg)
;;;; ;;;;
(require "test") (require "test")
...@@ -101,6 +101,11 @@ ...@@ -101,6 +101,11 @@
(test "Extended string-ci<?.3" #t (string-ci<? "a" "B" "c" "D")) (test "Extended string-ci<?.3" #t (string-ci<? "a" "B" "c" "D"))
(test "Extended string-ci<?.4" #f (string-ci<? "a" "a" "A" "b")) (test "Extended string-ci<?.4" #f (string-ci<? "a" "a" "A" "b"))
(let ((str "abcdef"))
(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-subsection "Lists and Pairs") (test-subsection "Lists and Pairs")
...@@ -136,4 +141,3 @@ ...@@ -136,4 +141,3 @@
(make-list 4 42)) (make-list 4 42))
(test-section-end) (test-section-end)
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