ports.k (11610B)
1 ;; check.k & test-helpers.k should be loaded 2 ;; 3 ;; Tests of i/o features. 4 ;; 5 ;; TODO binary ports 6 ;; 7 ;; Utilities for testing input and output features: 8 ;; 9 ;; temp-file .......... temporary file for input and output 10 ;; temp-file-2 ........ second temporary file for input and output 11 ;; test-input-file .... pre-existing file for input 12 ;; nonexistent-file ... valid file name denoting non-existent file 13 ;; invalid-file ....... invalid file name 14 ;; 15 ;; ($input-test INPUT PROGRAM) ... evaluates PROGRAM with current 16 ;; input port initialized for reading from a temporary file 17 ;; prepared according to INPUT. If INPUT is a string, 18 ;; the contents of the file is the contents of the string. 19 ;; Otherwise, empty file is prepared. 20 ;; 21 ;; ($output-test PROGRAM) ... evaluates PROGRAM with current 22 ;; output port initialized for writing to a temporary file. 23 ;; Returns the contents of the temporary file as string. 24 ;; 25 26 ;; Hope that the file names will work under both Unix and Windows. 27 ($define! temp-file "klisp-ports-test-1.txt") 28 ($define! temp-file-2 "klisp-ports-test-2.txt") 29 ($define! test-input-file "tests/ports.k") 30 ($define! nonexistent-file "nonexistent-file.txt") 31 ($define! invalid-file "!@#$%^&*/invalid/file/name.txt") 32 33 ($define! prepare-input 34 ($lambda (text) 35 (with-output-to-file temp-file 36 ($lambda () ($if (string? text) 37 (display text) 38 #inert))))) 39 40 ($define! read-string-until-eof 41 ($lambda () 42 ($letrec 43 ( (loop ($lambda (prefix) 44 ($let ((c (read-char))) 45 ($if (eof-object? c) 46 #inert 47 ($sequence 48 (set-cdr! prefix (cons c ())) 49 (loop (cdr prefix))))))) 50 (buf (cons () ()))) 51 (loop buf) 52 (list->string (cdr buf))))) 53 54 ($define! eval-with-input 55 ($lambda (program denv) 56 (with-input-from-file temp-file ($lambda () (eval program denv))))) 57 58 ($define! eval-with-output 59 ($lambda (program denv) 60 (with-output-to-file temp-file ($lambda () (eval program denv))))) 61 62 ($define! $input-test 63 ($vau (input program) denv 64 (prepare-input input) 65 (eval-with-input program denv))) 66 67 ($define! $output-test 68 ($vau (program) denv 69 (eval-with-output program denv) 70 (with-input-from-file temp-file read-string-until-eof))) 71 72 ($define! call-with-closed-input-port 73 ($lambda (program) 74 ($let ((port (open-input-file test-input-file))) 75 (close-input-file port) 76 (program port)))) 77 78 ($define! call-with-closed-output-port 79 ($lambda (program) 80 ($let ((port (open-output-file temp-file))) 81 (close-output-file port) 82 (program port)))) 83 84 ;; 15.1.1 port? 85 86 ($check-predicate (port? (get-current-input-port) (get-current-output-port))) 87 ($check-predicate (port?)) 88 ($check-not-predicate (port? 0)) 89 ($check-not-predicate (port? #t)) 90 ($check-not-predicate (port? ())) 91 ($check-not-predicate (port? #inert)) 92 93 ;; 15.1.2 input-port? output-port? 94 95 ($check-predicate (input-port? (get-current-input-port))) 96 ($check-predicate (input-port?)) 97 ($check-predicate (output-port? (get-current-output-port))) 98 ($check-predicate (output-port?)) 99 100 ;; 15.1.3 with-input-from-file, with-output-to-file 101 ;; 102 ;; klisp documentation: 103 ;; 104 ;; The result of the applicatives with-input-from-file 105 ;; and with-output-from-file is inert. 106 ;; 107 ;; R5RS: 108 ;; 109 ;; With-input-from-file and with-output-to-file 110 ;; return(s) the value(s) yielded by thunk. 111 ;; 112 113 ($check equal? (with-input-from-file test-input-file ($lambda () 1)) 1) 114 ($check-error (with-input-from-file nonexistent-file ($lambda () 1))) 115 ($check-error (with-input-from-file invalid-file ($lambda () 1))) 116 117 ($check equal? (with-output-to-file temp-file ($lambda () 1)) 1) 118 ($check-error (with-output-to-file invalid-file ($lambda () 1))) 119 120 ($check equal? 121 ($let ((orig (get-current-input-port))) 122 (with-input-from-file test-input-file 123 ($lambda () (equal? orig (get-current-input-port))))) 124 #f) 125 126 ($check equal? 127 ($let ((orig (get-current-output-port))) 128 (with-output-to-file temp-file 129 ($lambda () (equal? orig (get-current-output-port))))) 130 #f) 131 132 ;; 15.1.4 get-current-input-port? get-current-output-port? 133 ;; Functionality covered by other tests 134 135 ;; 15.1.5 open-input-file open-output-file 136 ;; 15.1.6 close-input-file close-output-file 137 138 ($check-no-error 139 ($let ((p (open-input-file test-input-file))) 140 ($check-predicate (port? p)) 141 ($check-predicate (input-port? p)) 142 ($check-not-predicate (equal? p (get-current-input-port))) 143 ($check-not-predicate (equal? p (get-current-output-port))) 144 (close-input-file p) 145 (close-input-file p))) 146 147 ($check-error (call-with-closed-output-port close-input-file)) 148 149 ($check-no-error 150 ($let ((p (open-output-file temp-file))) 151 ($check-predicate (port? p)) 152 ($check-predicate (output-port? p)) 153 ($check-not-predicate (equal? p (get-current-input-port))) 154 ($check-not-predicate (equal? p (get-current-output-port))) 155 (close-output-file p) 156 (close-output-file p))) 157 158 ($check-error (call-with-closed-input-port close-output-file)) 159 160 ;; 15.1.7 read 161 ($check-predicate (eof-object? ($input-test #inert (read)))) 162 ($check-predicate (eof-object? ($input-test "" (read)))) 163 164 ($check equal? ($input-test "#inert" (read)) #inert) 165 ($check equal? ($input-test "(0 1 -1 #t #f #inert)" (read)) (list 0 1 -1 #t #f #inert)) 166 ($check equal? ($input-test "(1 2 (3 4 5) (6 . 7))" (read)) (list 1 2 (list 3 4 5) (list* 6 7))) 167 168 ($check equal? ($input-test "1 2" (read)) 1) 169 ($check equal? ($input-test "1 2" ($sequence (read) (read))) 2) 170 ($check-predicate (eof-object? ($input-test "1 2" ($sequence (read) (read) (read))))) 171 172 ($check-error ((read (get-current-output-port)))) 173 ($check-error (call-with-closed-input-port read)) 174 175 ;; 15.1.8 write 176 177 ($check equal? ($output-test #inert) "") 178 179 ($check equal? 180 ($output-test (write (list 123 12345678901234567890 1/2 -3.14))) 181 "(123 12345678901234567890 1/2 -3.14)") 182 ($check equal? 183 ($output-test (write (list #e+infinity #e-infinity #i+infinity #i-infinity #real #undefined))) 184 "(#e+infinity #e-infinity #i+infinity #i-infinity #real #undefined)") 185 ($check equal? 186 ($output-test (write (list #\x #\newline #\space))) 187 "(#\\x #\\newline #\\space)") 188 ($check equal? 189 ($output-test (write (list #t #f))) 190 "(#t #f)") 191 ($check equal? 192 ($output-test (write (list #inert #ignore))) 193 "(#inert #ignore)") 194 195 ($check equal? ($output-test (write "")) "\"\"") 196 ($check equal? ($output-test (write "a\\b\"")) "\"a\\\\b\\\"\"") 197 198 ($check equal? 199 ($output-test (write (list 1 2 (list 3 4 5) () (list* 6 7)))) 200 "(1 2 (3 4 5) () (6 . 7))") 201 ($check equal? 202 ($output-test (write ($quote #0=(1 2 #1=(3 4 . #0#) #2="abc" #3=(5 6 #1# #2# #3# . #0#))))) 203 "#0=(1 2 #1=(3 4 . #0#) #2=\"abc\" #3=(5 6 #1# #2# #3# . #0#))") 204 205 ($check-error (write 0 (get-current-input-port))) 206 ($check-error (call-with-closed-output-port ($lambda (p) (write 0 p)))) 207 208 ;; write-simple 209 ;; read-line 210 ;; 15.2.1 call-with-input-file call-with-output-file 211 ;; 15.2.2 load 212 ;; 15.2.3 get-module 213 ;; TODO 214 215 ;; Additional input functions: eof-object? read-char peek-char 216 217 ($check-predicate ($false-for-all? eof-object? 218 0 -1 #t #f () "" (get-current-input-port))) 219 220 ($check-predicate (eof-object? ($input-test "" (read-char)))) 221 ($check-predicate (eof-object? ($input-test "" (peek-char)))) 222 223 ($check equal? ($input-test "a" (read-char)) #\a) 224 ($check-predicate (eof-object? ($input-test "a" ($sequence (read-char) (read-char))))) 225 ($check equal? ($input-test "a" (peek-char)) #\a) 226 ($check equal? ($input-test "a" ($sequence (peek-char) (peek-char))) #\a) 227 ($check equal? ($input-test "a" ($sequence (peek-char) (peek-char) (peek-char))) #\a) 228 ($check equal? ($input-test "ab" ($sequence (read-char) (read-char))) #\b) 229 ($check equal? ($input-test "ab" ($sequence (peek-char) (read-char))) #\a) 230 231 ($check equal? ($input-test "a" (read-char (get-current-input-port))) #\a) 232 ($check-error ((read-char (get-current-output-port)))) 233 ($check-error (call-with-closed-input-port read-char)) 234 235 ($check equal? ($input-test "a" (peek-char (get-current-input-port))) #\a) 236 ($check-error ((peek-char (get-current-output-port)))) 237 ($check-error (call-with-closed-input-port peek-char)) 238 239 ;; Additional input functions: char-ready? 240 ;; TODO 241 242 ;; Additional output functions: write-char newline display flush-ouput-port 243 244 ($check equal? ($output-test (write-char #\a)) "a") 245 ($check equal? ($output-test (write-char #\a (get-current-output-port))) "a") 246 ($check-error (write-char #\a (get-current-input-port))) 247 ($check-error (call-with-closed-output-port ($lambda (p) (write-char #\a p)))) 248 249 ($check equal? ($output-test (newline)) (string #\newline)) 250 ($check equal? ($output-test (newline (get-current-output-port))) (string #\newline)) 251 ($check-error (newline (get-current-input-port))) 252 ($check-error (call-with-closed-output-port newline)) 253 254 ($check equal? ($output-test (display "")) "") 255 ($check equal? ($output-test (display "abc")) "abc") 256 ($check equal? ($output-test (display "a\\b\"")) "a\\b\"") 257 ($check equal? ($output-test (display #\x)) "x") 258 ($check equal? ($output-test (display "abc" (get-current-output-port))) "abc") 259 ($check-error ($output-test (display "abc" (get-current-input-port)))) 260 ($check-error (call-with-closed-output-port ($lambda (p) (display "abc" p)))) 261 262 ($check equal? ($output-test (flush-output-port)) "") 263 ($check equal? ($output-test (flush-output-port (get-current-output-port))) "") 264 ($check-error (flush-output-port (get-current-input-port))) 265 ($check-error (call-with-closed-output-port flush-output-port)) 266 267 ;; Currently, write and write-char flush automatically 268 ;; and flush-output-port causes no effect. 269 ;; 270 ;; ($define! colliding-output-test 271 ;; ($lambda (combiner) 272 ;; (call-with-output-file temp-file 273 ;; ($lambda (p1) 274 ;; (call-with-output-file temp-file 275 ;; ($lambda (p2) 276 ;; (combiner p1 p2))))) 277 ;; (with-input-from-file temp-file read-string-until-eof))) 278 ;; 279 ;; ($check equal? 280 ;; (colliding-output-test ($lambda (p1 p2) 281 ;; (display "1" p1) 282 ;; (display "2" p2) 283 ;; (flush-output-port p1) 284 ;; (flush-output-port p2))) 285 ;; "12") 286 ;; 287 ;; ($check equal? 288 ;; (colliding-output-test ($lambda (p1 p2) 289 ;; (display "1" p1) 290 ;; (display "2" p2) 291 ;; (flush-output-port p2) 292 ;; (flush-output-port p1))) 293 ;; "21") 294 295 296 ;; File manipulation functions: file-exists? delete-file rename-file 297 298 ($check-predicate (file-exists? test-input-file)) 299 ($check-not-predicate (file-exists? nonexistent-file)) 300 ($check-not-predicate (file-exists? invalid-file)) 301 302 ($check-no-error (prepare-input "test")) 303 ($check-predicate (file-exists? temp-file)) 304 ($check-no-error (delete-file temp-file)) 305 ($check-not-predicate (file-exists? temp-file)) 306 ($check-error (delete-file nonexistent-file)) 307 ($check-error (delete-file invalid-file)) 308 309 ($check-no-error (prepare-input "test")) 310 ($check-predicate (file-exists? temp-file)) 311 ($check-not-predicate (file-exists? temp-file-2)) 312 ($check-no-error (rename-file temp-file temp-file-2)) 313 ($check-predicate (file-exists? temp-file-2)) 314 ($check-not-predicate (file-exists? temp-file)) 315 ($check-no-error (delete-file temp-file-2)) 316 317 ($check-error (rename-file nonexistent-file temp-file)) 318 ($check-error (rename-file invalid-file temp-file)) 319 320 ;; Cleanup. 321 ;; Check that temporary files were deleted. 322 323 ($check-not-predicate (file-exists? temp-file)) 324 ($check-not-predicate (file-exists? temp-file-2))