about summary refs log tree commit diff stats
diff options
context:
space:
mode:
-rw-r--r--chicanery.extras.scm150
-rw-r--r--extras.scm50
2 files changed, 50 insertions, 150 deletions
diff --git a/chicanery.extras.scm b/chicanery.extras.scm deleted file mode 100644 index ae2823e..0000000 --- a/chicanery.extras.scm +++ /dev/null
@@ -1,150 +0,0 @@
1(export list-map list-for-each list-append
2 map for-each append)
3
4(define list-map map)
5(define list-for-each for-each)
6(define list-append append)
7
8(define (map proc . collections)
9 (let ((first (car collections))) ; we only need to check the first one
10 (cond
11 ((list? first)
12 (apply list-map proc collections))
13 ((vector? first)
14 (apply vector-map proc collections))
15 ((string? first)
16 (apply string-map proc collections))
17 (else (error "Bad datatype" first)))))
18
19(define (for-each proc . collections)
20 (let ((first (car collections))) ; we only need to check the first one
21 (cond
22 ((list? first)
23 (apply list-for-each proc collections))
24 ((vector? first)
25 (apply vector-for-each proc collections))
26 ((string? first)
27 (apply string-for-each proc collections))
28 (else (error "Bad datatype" first)))))
29
30(define (append . collections)
31 (let ((first (car collections))) ; we only need to check the first one
32 (cond
33 ((list? first)
34 (apply list-append collections))
35 ((vector? first)
36 (apply vector-append collections))
37 ((string? first)
38 (apply string-append collections))
39 ((bytevector? first)
40 (apply bytevector-append collections))
41 (else (error "Bad datatype" first)))))
42
43;;; Extended generic functions.
44;; These functions already have a list- version defined, but no non-prefixed
45;; one. So I'm fixing that.
46(define (ref collection k)
47 (cond
48 ((list? collection)
49 (list-ref collection k))
50 ((vector? collection)
51 (vector-ref collection k))
52 ((string? collection)
53 (string-ref collection k))
54 ((bytevector? collection)
55 (bytevector-u8-ref collection k))
56 (else (error "Bad datatype" collection))))
57
58;; I'm not going to generalize -copy! because I don't think it's a great idea,
59;; really.
60(define (copy collection)
61 (cond
62 ((list? collection)
63 (list-copy collection))
64 ((vector? collection)
65 (vector-copy collection))
66 ((string? collection)
67 (string-copy collection))
68 ((bytevector? collection)
69 (bytevector-copy collection))
70 (else (error "Bad datatype" collection))))
71
72;;; Definitions that should be in scheme
73;; This sections should be as small as possible
74
75(export read-port
76 read-port-chunk-size)
77
78
79(define (%read-port port)
80 (let ((chunk-size (read-port-chunk-size)))
81 (let loop ((next (read-string chunk-size port))
82 (blank? #f)
83 (acc '()))
84 (cond
85 ((or (eof-object? next)
86 (and blank? (equal? next "")))
87 (apply string-append (reverse acc)))
88 ((equal? next "")
89 (loop (read-string chunk-size port)
90 #t
91 (cons next acc)))
92 (else
93 (loop (read-string chunk-size port)
94 blank?
95 (cons next acc)))))))
96
97(define read-port-chunk-size
98 (make-parameter 512))
99
100(define read-port
101 (case-lambda
102 (() (%read-port (current-input-port)))
103 ((p) (%read-port p))))
104
105(export atom? defined?)
106
107(define (atom? x)
108 (not (or (null? x)
109 (pair? x))))
110
111(define (defined? sym)
112 (call-with-current-continuation
113 (lambda (k)
114 (with-exception-handler
115 (lambda (e) (k #f))
116 (lambda ()
117 (eval sym (interaction-environment))
118 #t)))))
119
120(export with-output-to-string
121 with-input-from-string)
122
123(define (with-output-to-string thunk)
124 (call-with-port (open-output-string)
125 (lambda (port)
126 (parameterize ((current-output-port port))
127 (thunk))
128 (get-output-string port))))
129
130(define (with-input-from-string s thunk)
131 (call-with-port (open-input-string s)
132 (lambda (port)
133 (parameterize ((current-input-port port))
134 (thunk)))))
135
136(export displayed ->string written print)
137
138(define (displayed x)
139 (with-output-to-string
140 (lambda () (display x))))
141
142(define (written x)
143 (with-output-to-string
144 (lambda () (write x))))
145
146(define (print . xs)
147 (for-each display xs)
148 (newline))
149
150(define ->string displayed)
diff --git a/extras.scm b/extras.scm new file mode 100644 index 0000000..423c78f --- /dev/null +++ b/extras.scm
@@ -0,0 +1,50 @@
1;;; Chicanery extras
2
3(export slurp)
4
5(define slurp
6 (case-lambda
7 (() (slurp (current-input-port)))
8 ((port)
9 (let loop ((ch (read-char port))
10 (acc '()))
11 (if (eof-object? ch)
12 (list->string (reverse acc))
13 (loop (read-char port)
14 (cons ch acc)))))))
15
16
17(export with-output-to-string
18 with-input-from-string)
19
20(define (with-output-to-string thunk)
21 (call-with-port (open-output-string)
22 (lambda (port)
23 (parameterize ((current-output-port port))
24 (thunk))
25 (get-output-string port))))
26
27(define (with-input-from-string s thunk)
28 (call-with-port (open-input-string s)
29 (lambda (port)
30 (parameterize ((current-input-port port))
31 (thunk)))))
32
33
34(export displayed ->string
35 written
36 print)
37
38(define (displayed x)
39 (with-output-to-string
40 (lambda () (display x))))
41
42(define ->string displayed)
43
44(define (written x)
45 (with-output-to-string
46 (lambda () (write x))))
47
48(define (print . xs)
49 (for-each display xs)
50 (newline))