blob: 27968dfdbaa376f03d684894ad93cfea1b98dc47 (
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
|
;;; chicanery extras --- extra stuff from ur old pal acdw
(export list-map
list-for-each
list-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 atom?
read-port
read-port-chunk-size)
(define (atom? x)
(not (pair? 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))))
|
