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