blob: bcb4929965f34c483c5ecc9cbe5609317fae49bd (
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
146
147
148
149
150
151
152
153
154
155
156
157
|
;;; chicanery extras --- extra stuff from ur old pal acdw
(export list-map list-for-each list-append
map for-each append)
;;; Generalized map, for-each, ...
;; List versions are renamed `list-<function>'. Un-prefixed versions work
;; with any (default) datatype. TODO: generalize?
(define list-map map)
(define list-for-each for-each)
(define list-append append)
(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)))))
(export ref
copy)
;;; 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))))
;;; Functions that should be in scheme
;; This sections should be as small as possible
(export read-port
read-port-chunk-size)
(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))))
(export atom? defined?)
(define (atom? x)
(not (or (null? x)
(pair? x))))
(define (defined? sym)
(call-with-current-continuation
(lambda (k)
(with-exception-handler
(lambda (e) (k #f))
(lambda ()
(eval sym (interaction-environment))
#t)))))
(export with-output-to-string
with-input-from-string)
(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)))))
(export displayed ->string written print)
(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)
|
