/usr/lib/write-to-string.scm is in scheme9 2013.11.26-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 | ; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2009
; Placed in the Public Domain
;
; (write-to-string object) ==> string
; (display-to-string object) ==> string
;
; (load-from-library "write-to-string.scm")
;
; Write the external representation of the given OBJECT to a fresh
; string. WRITE-TO-STRING is like WRITE but writes its output to a
; string instead of an output port. DISPLAY-TO-STRING is like
; DISPLAY but writes its output to a string.
;
; Example: (write-to-string '(a 1 #\c #(v) #t "str" "\"s\"" (a . d)))
; ==> "(a 1 #\\c #(v) #t \"str\" \"\\\"s\\\"\" (a . d))"
;
; (display-to-string '(a 1 #\c #(v) #t "str" "\"s\"" (a . d)))
; ==> "(a 1 c #(v) #t str \"s\" (a . d))"
(define (make-string-writer readable)
(lambda (x)
(define (stringify-improper-list a first)
(cond
((pair? a)
(string-append (if first "" " ")
(to-string (car a))
(stringify-improper-list (cdr a) #f)))
((null? a)
"")
(else
(string-append " . " (to-string a)))))
(define (char->string c)
(if readable
(let ((v (char->integer c)))
(cond ((= v 10)
"#\\newline")
((= v 32)
"#\\space")
((or (<= 0 v 31)
(> v 126))
(string-append "#<unrepresentable character, code="
(number->string v)
">"))
(else
(string-append "#\\" (string c)))))
(string c)))
(define (quote-string s)
(list->string
(let q ((si (string->list s))
(so '()))
(cond ((null? si)
(reverse! so))
((char=? #\\ (car si))
(q (cdr si) (append (list #\\ #\\) so)))
((char=? #\" (car si))
(q (cdr si) (append (list #\" #\\) so)))
(else
(q (cdr si) (cons (car si) so)))))))
(define (to-string x)
(cond ((eq? #t x)
"#t")
((eq? #f x)
"#f")
((symbol? x)
(symbol->string x))
((number? x)
(number->string x))
((char? x)
(char->string x))
((string? x)
(if readable
(string-append "\"" (quote-string x) "\"")
x))
((null? x)
"()")
((pair? x)
(if (and (pair? (cdr x))
(null? (cddr x)))
(case (car x)
((quote)
(string-append "'" (to-string (cadr x))))
((quasiquote)
(string-append "`" (to-string (cadr x))))
((unquote)
(string-append "," (to-string (cadr x))))
((unquote-splicing)
(string-append ",@" (to-string (cadr x))))
(else
(string-append "("
(stringify-improper-list x #t)
")")))
(string-append "("
(stringify-improper-list x #t)
")")))
((vector? x)
(string-append "#" (to-string (vector->list x))))
((procedure? x)
"#<procedure>")
((eof-object? x)
"#<eof>")
(else
"#<unspecific>")))
(to-string x)))
(define write-to-string (make-string-writer #t))
(define display-to-string (make-string-writer #f))
|