blob: f26442477af3f759ca308aeee74170dad1c7f0db (
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
|
;;; chicanery extras --- extra stuff from ur old pal acdw
;;; Generalized map, for-each, ...
;; List versions are renamed `list-<function>'. Un-prefixed versions work
;; with any (default) datatype. TODO: generalize?
(define list-map scheme/map)
(define list-for-each scheme/for-each)
(define list-append scheme/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)))))
;;; 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)
|
