blob: f9bb4a16fb1792e283a6ff56d840c6d677eea25b (
plain)
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
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
|
(module (chicanery extras) ( append for-each map
list-append list-for-each list-map
ref copy
atom? defined?
read-port-chunk-size read-port
with-output-to-string with-input-from-string
displayed written print ->string)
(import scheme (chicanery base))
(define list-append append)
(define list-for-each for-each)
(define list-map map)
(define (map proc . collections)
(let ((first (car collections))) ; we only need to check the first one
(cond
((list? first)
(apply list-map proc collections))
((vector? first)
(apply vector-map proc collections))
((string? first)
(apply string-map proc collections))
(else (error "Bad datatype" first)))))
(define (for-each proc . collections)
(let ((first (car collections))) ; we only need to check the first one
(cond
((list? first)
(apply list-for-each proc collections))
((vector? first)
(apply vector-for-each proc collections))
((string? first)
(apply string-for-each proc collections))
(else (error "Bad datatype" first)))))
(define (append . collections)
(let ((first (car collections))) ; we only need to check the first one
(cond
((list? first)
(apply list-append collections))
((vector? first)
(apply vector-append collections))
((string? first)
(apply string-append collections))
((bytevector? first)
(apply bytevector-append collections))
(else (error "Bad datatype" first)))))
;;; Extended generic functions.
;; These functions already have a list- version defined, but no non-prefixed
;; one. So I'm fixing that.
(define (ref collection k)
(cond
((list? collection)
(list-ref collection k))
((vector? collection)
(vector-ref collection k))
((string? collection)
(string-ref collection k))
((bytevector? collection)
(bytevector-u8-ref collection k))
(else (error "Bad datatype" collection))))
;; I'm not going to generalize -copy! because I don't think it's a great idea,
;; really.
(define (copy collection)
(cond
((list? collection)
(list-copy collection))
((vector? collection)
(vector-copy collection))
((string? collection)
(string-copy collection))
((bytevector? collection)
(bytevector-copy collection))
(else (error "Bad datatype" collection))))
;;; Definitions that should be in scheme
;; This sections should be as small as possible
(define (atom? x)
(and (not (pair? x))
(not (null? x))))
(define read-port-chunk-size
(make-parameter 512))
(define (%read-port port)
(let ((chunk-size (read-port-chunk-size)))
(let loop ((next (read-string chunk-size port))
(blank? #f)
(acc '()))
(cond
((or (eof-object? next)
(and blank? (equal? next "")))
(apply string-append (reverse acc)))
((equal? next "")
(loop (read-string chunk-size port)
#t
(cons next acc)))
(else
(loop (read-string chunk-size port)
blank?
(cons next acc)))))))
(define read-port
(case-lambda
(() (%read-port (current-input-port)))
((p) (%read-port p))))
(define (defined? sym)
(call-with-current-continuation
(lambda (k)
(with-exception-handler
(lambda (e) (k #f))
(lambda ()
(eval sym (interaction-environment))
#t)))))
(define (with-output-to-string thunk)
(call-with-port (open-output-string)
(lambda (port)
(parameterize ((current-output-port port))
(thunk))
(get-output-string port))))
(define (with-input-from-string s thunk)
(call-with-port (open-input-string s)
(lambda (port)
(parameterize ((current-input-port port))
(thunk)))))
(define (displayed x)
(with-output-to-string
(lambda () (display x))))
(define (written x)
(with-output-to-string
(lambda () (write x))))
(define (print . xs)
(for-each display xs)
(newline))
(define ->string displayed))
|
