So this is a time for requests, especially things that don't
require a lot of work from me, but would be useful to you.
I guess "all final SRFIs" is too much :-). At the top of my list is:
- srfi-13
- and-let*
- args-fold
Below is some srfi-13 code that we use (not all the functions
implement the spec properly). I don't know why we didn't just copy
the srfi-13 reference implementation, but you're welcome to use our
code if you like.
Regards,
Chris Dean
------------------------------------------------------------------------
;;;
;;; srfi-13
;;;
(define (string-null? (str :: <string>))
(= (string-length str) 0))
;; string-join
;; See http://srfi.schemers.org/srfi-13/srfi-13.html#string-join
(define (string-join string-list
#!optional (delimiter " ") (grammar 'infix))
(define (form-list before lst after delim)
;; Using this named let gives us tail recursion in Kawa.
(let loop ((acc (cons before '())) (lst lst) (after after) (delim delim))
(if (null? lst)
(reverse! (cons after acc))
(loop (cons (car lst) (cons delim acc))
(cdr lst)
after delim))))
(define (join-as-list)
(if (null? string-list)
(case grammar ; No list to join
((strict-infix) (error "string-join requires list"))
((prefix infix suffix) '()))
(case grammar ; Join this list
((infix strict-infix) (form-list (car string-list) (cdr string-list)
"" delimiter))
((prefix) (form-list "" string-list "" delimiter))
((suffix) (form-list (car string-list) (cdr string-list)
delimiter delimiter)))))
(string-concatenate (join-as-list)))
;; Kawa doesn't have an apply length limit, so this implementation is
;; fine.
(define (string-concatenate string-list)
(apply string-append string-list))
(define (string-prefix? pre full #!optional (start1 0) end1 (start2 0) end2)
(letrec ((f (lambda (pre full start1 end1 start2 end2)
(cond ((equal? start1 end1) #t)
((equal? start2 end2) #f)
((char=? (string-ref pre start1) (string-ref full start2))
(f pre full (+ start1 1) end1 (+ start2 1) end2))
(else #f)))))
(if (not end1)
(f pre full start1 (string-length pre) start2 (string-length full))
(if (not end2)
(f pre full start1 end1 start2 (string-length full))
(f pre full start1 end1 start2 end2)))))
(define (string-suffix? suf full #!optional (start1 0) end1 (start2 0) end2)
(letrec ((f (lambda (suf full start1 end1 start2 end2)
(cond ((equal? start1 end1) #t)
((equal? start2 end2) #f)
((char=? (string-ref suf (- end1 1))
(string-ref full (- end2 1)))
(f suf full start1 (- end1 1) start2 (- end2 1)))
(else #f)))))
(if (not end1)
(f suf full start1 (string-length suf) start2 (string-length full))
(if (not end2)
(f suf full start1 end1 start2 (string-length full))
(f suf full start1 end1 start2 end2)))))
(define (string-prefix-length s1 s2 #!optional (start1 0) end1 (start2 0) end2)
(letrec ((f (lambda (s1 s2 start1 end1 start2 end2)
(cond ((equal? start1 end1) 0)
((equal? start2 end2) 0)
((char=? (string-ref s1 start1) (string-ref s2 start2))
(+ 1 (f s1 s2 (+ start1 1) end1 (+ start2 1) end2)))
(else 0)))))
(if (not end1)
(f s1 s2 start1 (string-length s1) start2 (string-length s2))
(if (not end2)
(f s1 s2 start1 end1 start2 (string-length s2))
(f s1 s2 start1 end1 start2 end2)))))
(define (string-suffix-length s1 s2 #!optional (start1 0) end1 (start2 0) end2)
(letrec ((f (lambda (s1 s2 start1 end1 start2 end2)
(cond ((equal? start1 end1) 0)
((equal? start2 end2) 0)
((char=? (string-ref s1 (- end1 1))
(string-ref s2 (- end2 1)))
(+ 1 (f s1 s2 start1 (- end1 1) start2 (- end2 1))))
(else 0)))))
(if (not end1)
(f s1 s2 start1 (string-length s1) start2 (string-length s2))
(if (not end2)
(f s1 s2 start1 end1 start2 (string-length s2))
(f s1 s2 start1 end1 start2 end2)))))
(define (string-prefix-ci? pre full #!optional (start1 0) end1 (start2 0) end2)
(letrec ((f (lambda (pre full start1 end1 start2 end2)
(cond ((equal? start1 end1) #t)
((equal? start2 end2) #f)
((char=? (char-downcase (string-ref pre start1))
(char-downcase (string-ref full start2)))
(f pre full (+ start1 1) end1 (+ start2 1) end2))
(else #f)))))
(if (not end1)
(f pre full start1 (string-length pre) start2 (string-length full))
(if (not end2)
(f pre full start1 end1 start2 (string-length full))
(f pre full start1 end1 start2 end2)))))
(define (string-suffix-ci? suf full #!optional (start1 0) end1 (start2 0) end2)
(letrec ((f (lambda (suf full start1 end1 start2 end2)
(cond ((equal? start1 end1) #t)
((equal? start2 end2) #f)
((char=? (char-downcase (string-ref suf (- end1 1)))
(char-downcase (string-ref full (- end2 1))))
(f suf full start1 (- end1 1) start2 (- end2 1)))
(else #f)))))
(if (not end1)
(f suf full start1 (string-length suf) start2 (string-length full))
(if (not end2)
(f suf full start1 end1 start2 (string-length full))
(f suf full start1 end1 start2 end2)))))
(define (string-prefix-length-ci s1 s2 #!optional
(start1 0) end1 (start2 0) end2)
(letrec ((f (lambda (s1 s2 start1 end1 start2 end2)
(cond ((equal? start1 end1) 0)
((equal? start2 end2) 0)
((char=? (char-downcase (string-ref s1 start1))
(char-downcase (string-ref s2 start2)))
(+ 1 (f s1 s2 (+ start1 1) end1 (+ start2 1) end2)))
(else 0)))))
(if (not end1)
(f s1 s2 start1 (string-length s1) start2 (string-length s2))
(if (not end2)
(f s1 s2 start1 end1 start2 (string-length s2))
(f s1 s2 start1 end1 start2 end2)))))
(define (string-suffix-length-ci s1 s2 #!optional
(start1 0) end1 (start2 0) end2)
(letrec ((f (lambda (s1 s2 start1 end1 start2 end2)
(cond ((equal? start1 end1) 0)
((equal? start2 end2) 0)
((char=? (char-downcase (string-ref s1 (- end1 1)))
(char-downcase (string-ref s2 (- end2 1))))
(+ 1 (f s1 s2 start1 (- end1 1) start2 (- end2 1))))
(else 0)))))
(if (not end1)
(f s1 s2 start1 (string-length s1) start2 (string-length s2))
(if (not end2)
(f s1 s2 start1 end1 start2 (string-length s2))
(f s1 s2 start1 end1 start2 end2)))))
(define (string-replace s ins start1 end1 #!optional (ins-start 0) ins-end)
(letrec ((f (lambda (s ins start1 end1 ins-start ins-end)
(string-append (substring s 0 start1)
(substring ins ins-start ins-end)
(substring s end1 (string-length s))))))
(if (not ins-end)
(f s ins start1 end1 ins-start (string-length ins))
(f s ins start1 end1 ins-start ins-end))))
(define (string-contains (string :: <String>) (substring :: <String>))
(let ((index (java.lang.String:indexOf string substring)))
(if (= index -1)
#f
index)))
(define (string-contains-ci (string :: <String>) (substring :: <String>))
(let ((lc-string (java.lang.String:toLowerCase string))
(lc-substring (java.lang.String:toLowerCase substring)))
(string-contains lc-string lc-substring)))
(define (string-tokenize s #!optional (token-set " "))
(let ((tokenizer (java-string-tokenizer:new s token-set)))
(let loop ((acc '()))
(if (not (java-string-tokenizer:hasMoreTokens tokenizer))
(reverse! acc)
(loop (cons (->string (java-string-tokenizer:nextToken tokenizer))
acc))))))
(define (string-drop s n)
(substring s n (string-length s)))
(define (string-drop-right s n)
(substring s 0 (- (string-length s) n)))
(define (string-reverse s #!optional (start 0) (end #f))
(let ((buf (java.lang.StringBuffer:new)))
(gnu.lists.FString:get-chars s buf)
(java.lang.StringBuffer:reverse buf)
(gnu.lists.FString:new (as <java.lang.StringBuffer> buf))))
;; Quick and dirty version of string-trim
(define (string-trim (string :: <String>))
(string-copy (->string (java.lang.String:trim string))))
(define (string-take s n)
(if (= n 1)
(string (string-ref s 0))
(string-append (string-take s (- n 1)) (string (string-ref s (- n 1))))))
(define (string-take-right s n)
(if (= n 1)
(string (string-ref s (- (string-length s) 1)))
(string-append (string (string-ref s (- (string-length s) n)))
(string-take-right s (- n 1)))))
(define (string-pad s len #!optional (char #\space))
(letrec ((f
(lambda (s len char)
(cond ((< len (string-length s))
(string-drop s (- (string-length s) len)))
((= len (string-length s)) s)
((> len (string-length s))
(f (string-append (string char) s) len char))))))
(f s len char)))
(define (substring/shared s start #!optional (end #f))
(if end
(if (= start end)
""
(substring s start end))
(if (= start 0)
s
(substring s start (string-length s)))))
;;;
;;; Other string functions
;;;
(define-constant *NULL-AS-STRING* (format "~A" #!null))
(define (->string x) :: <string>
(if (eq? x #!null)
*NULL-AS-STRING*
(if (string? x)
x
(format "~A" x))))
(define (force-string-append #!rest (args :: <Object[]>)) :: <string>
(string-concatenate (map-primitive-array ->string args)))
(define (->java-string x) :: <String>
x)
(define (string->sexp str)
(read (open-input-string (->string str))))
(define (safe-string->sexp str)
(if (nullish? str) '() (string->sexp (->string str))))