144 lines
4.5 KiB
Scheme
144 lines
4.5 KiB
Scheme
(define (string-fill! s char . maybe-start+end)
|
|
(check-arg char? char string-fill!)
|
|
(let-string-start+end (start end) string-fill! s maybe-start+end
|
|
(do ((i (- end 1) (- i 1)))
|
|
((< i start))
|
|
(string-set! s i char))))
|
|
|
|
(define (string-copy! to tstart from . maybe-fstart+fend)
|
|
(let-string-start+end (fstart fend) string-copy! from maybe-fstart+fend
|
|
(check-arg integer? tstart string-copy!)
|
|
(check-substring-spec string-copy! to tstart (+ tstart (- fend fstart)))
|
|
(%string-copy! to tstart from fstart fend)))
|
|
|
|
;;; Library-internal routine
|
|
#;(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)))))
|
|
|
|
(define (string->list s . maybe-start+end)
|
|
(let-string-start+end (start end) string->list s maybe-start+end
|
|
(do ((i (- end 1) (- i 1))
|
|
(ans '() (cons (string-ref s i) ans)))
|
|
((< i start) ans))))
|
|
|
|
(define (string->vector s . maybe-start+end)
|
|
(let-string-start+end (start end) string->vector s maybe-start+end
|
|
(let ((vector (make-vector (- end start))))
|
|
(do ((i (- end 1) (- i 1)))
|
|
((< i start) vector)
|
|
(vector-set! vector (- i start) (string-ref s i))))))
|
|
|
|
(define (vector->string vector . maybe-start+end)
|
|
(let ((start 0) (end (vector-length vector)))
|
|
(case (length maybe-start+end)
|
|
((1) (set! start (car maybe-start+end)))
|
|
((2) (set! end (cadr maybe-start+end))))
|
|
(let ((s (make-string (- end start))))
|
|
(do ((i (- end 1) (- i 1)))
|
|
((< i start) s)
|
|
(string-set! s (- i start) (vector-ref vector i))))))
|
|
|
|
(define (string-map f x . rest)
|
|
|
|
(define (string-map1 f x)
|
|
(list->string (map f (string->list x))))
|
|
|
|
(define (string-map2 f x y)
|
|
(list->string (map f (string->list x) (string->list y))))
|
|
|
|
(define (string-mapn f lists)
|
|
(list->string (apply map f (map string->list lists))))
|
|
|
|
(case (length rest)
|
|
((0) (string-map1 f x))
|
|
((1) (string-map2 f x (car rest)))
|
|
(else (string-mapn f (cons x rest)))))
|
|
|
|
(define (string-for-each f s . rest)
|
|
|
|
(define (for-each1 i n)
|
|
(if (< i n)
|
|
(begin (f (string-ref s i))
|
|
(for-each1 (+ i 1) n))
|
|
(if #f #f)))
|
|
|
|
(define (for-each2 s2 i n)
|
|
(if (< i n)
|
|
(begin (f (string-ref s i) (string-ref s2 i))
|
|
(for-each2 s2 (+ i 1) n))
|
|
(if #f #f)))
|
|
|
|
(define (for-each-n revstrings i n)
|
|
(if (< i n)
|
|
(do ((rev revstrings (cdr rev))
|
|
(chars '() (cons (string-ref (car rev) i) chars)))
|
|
((null? rev)
|
|
(apply f chars)
|
|
(for-each-n revstrings (+ i 1) n)))
|
|
(if #f #f)))
|
|
|
|
(let ((n (string-length s)))
|
|
(cond ((null? rest)
|
|
(for-each1 0 n))
|
|
((and (null? (cdr rest))
|
|
(string? (car rest))
|
|
(= n (string-length (car rest))))
|
|
(for-each2 (car rest) 0 n))
|
|
(else
|
|
(let ((args (cons s rest)))
|
|
(do ((ss rest (cdr ss)))
|
|
((null? ss)
|
|
(for-each-n (reverse args) 0 n))
|
|
(let ((x (car ss)))
|
|
(if (or (not (string? x))
|
|
(not (= n (string-length x))))
|
|
(error
|
|
"illegal-arguments"
|
|
(cons f args))))))))))
|
|
|
|
(define (string-copy s . maybe-start+end)
|
|
(let-string-start+end (start end) string-copy! s maybe-start+end
|
|
(%substring s start end)))
|
|
|
|
(cond-expand
|
|
(chicken
|
|
#;imported)
|
|
(else
|
|
(define read-string
|
|
(case-lambda
|
|
((k) (read-string k (current-input-port)))
|
|
((k port)
|
|
(let loop ((i 0) (o '()))
|
|
(if (>= i k)
|
|
(list->string (reverse o))
|
|
(let ((c (read-char port)))
|
|
(if (eof-object? c)
|
|
(if (= i 0)
|
|
c
|
|
(list->string (reverse o)))
|
|
(loop (+ i 1) (cons c o)))))))))))
|
|
|
|
;; Chicken's write-string is incompatible with R7RS
|
|
(define write-string
|
|
(case-lambda
|
|
((str) (display str))
|
|
((str port) (display str port))
|
|
((str port start) (write-string str port start (string-length str)))
|
|
((str port start end) (display (%substring str start end) port))))
|
|
|
|
#;(define (eof-object)
|
|
(let ((port (open-input-string "")))
|
|
(dynamic-wind
|
|
(lambda () #f)
|
|
(lambda () (read-char port))
|
|
(lambda () close-input-port port))))
|