1;; 2;; Copyright (c) 2002 by The XFree86 Project, Inc. 3;; 4;; Permission is hereby granted, free of charge, to any person obtaining a 5;; copy of this software and associated documentation files (the "Software"), 6;; to deal in the Software without restriction, including without limitation 7;; the rights to use, copy, modify, merge, publish, distribute, sublicense, 8;; and/or sell copies of the Software, and to permit persons to whom the 9;; Software is furnished to do so, subject to the following conditions: 10;; 11;; The above copyright notice and this permission notice shall be included in 12;; all copies or substantial portions of the Software. 13;; 14;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 15;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 16;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL 17;; THE XFREE86 PROJECT BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 18;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF 19;; OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 20;; SOFTWARE. 21;; 22;; Except as contained in this notice, the name of the XFree86 Project shall 23;; not be used in advertising or otherwise to promote the sale, use or other 24;; dealings in this Software without prior written authorization from the 25;; XFree86 Project. 26;; 27;; Author: Paulo César Pereira de Andrade 28;; 29;; 30;; $XFree86: xc/programs/xedit/lisp/test/stream.lsp,v 1.3 2002/12/06 03:25:29 paulo Exp $ 31;; 32 33;; most format tests from the cltl second edition samples 34 35;; basic io/format/pathname/stream tests 36 37(defun do-format-test (error-test expect arguments 38 &aux result (error t) unused error-value) 39 (multiple-value-setq 40 (unused error-value) 41 (ignore-errors 42 (setq result (apply #'format nil arguments)) 43 (setq error nil) 44 ) 45 ) 46 (if error-test 47 (or error 48 (format t "ERROR: no error for (format nil~{ ~S~}), result was ~S~%" 49 arguments result)) 50 (if error 51 (format t "ERROR: (format nil~{ ~S~}) => ~S~%" arguments error-value) 52 (or (string= result expect) 53 (format t "(format nil~{ ~S~}) => should be ~S not ~S~%" 54 arguments expect result))) 55 ) 56) 57 58(defun format-test (expect &rest arguments) 59 (do-format-test nil expect arguments)) 60 61(defun format-error (&rest arguments) 62 (do-format-test t nil arguments)) 63 64 65 66(defun compare-test (test expect function arguments 67 &aux result (error t) unused error-value) 68 (multiple-value-setq 69 (unused error-value) 70 (ignore-errors 71 (setq result (apply function arguments)) 72 (setq error nil) 73 ) 74 ) 75 (if error 76 (format t "ERROR: (~S~{ ~S~}) => ~S~%" function arguments error-value) 77 (or (funcall test result expect) 78 (format t "(~S~{ ~S~}) => should be ~S not ~S~%" 79 function arguments expect result 80 ) 81 ) 82 ) 83) 84 85(defun compare-eval (test expect form 86 &aux result (error t) unused error-value) 87 (multiple-value-setq 88 (unused error-value) 89 (ignore-errors 90 (setq result (eval form)) 91 (setq error nil) 92 ) 93 ) 94 (if error 95 (format t "ERROR: ~S => ~S~%" form error-value) 96 (or (funcall test result expect) 97 (format t "~S => should be ~S not ~S~%" 98 form expect result 99 ) 100 ) 101 ) 102) 103 104(defun error-test (function &rest arguments &aux result (error t)) 105 (ignore-errors 106 (setq result (apply function arguments)) 107 (setq error nil) 108 ) 109 (or error 110 (format t "ERROR: no error for (~S~{ ~S~}), result was ~S~%" 111 function arguments result) 112 ) 113) 114 115(defun error-eval (form &aux result (error t)) 116 (ignore-errors 117 (setq result (eval form)) 118 (setq error nil) 119 ) 120 (or error 121 (format t "ERROR: no error for ~S, result was ~S~%" form result) 122 ) 123) 124 125(defun eq-test (expect function &rest arguments) 126 (compare-test #'eq expect function arguments)) 127 128(defun eql-test (expect function &rest arguments) 129 (compare-test #'eql expect function arguments)) 130 131(defun equal-test (expect function &rest arguments) 132 (compare-test #'equal expect function arguments)) 133 134(defun equalp-test (expect function &rest arguments) 135 (compare-test #'equalp expect function arguments)) 136 137(defun eq-eval (expect form) 138 (compare-eval #'eq expect form)) 139 140(defun eql-eval (expect form) 141 (compare-eval #'eql expect form)) 142 143(defun equal-eval (expect form) 144 (compare-eval #'equal expect form)) 145 146(defun equalp-eval (expect form) 147 (compare-eval #'equalp expect form)) 148 149(defun bool-test (expect function &rest arguments 150 &aux result (error t) unused error-value) 151 (multiple-value-setq 152 (unused error-value) 153 (ignore-errors 154 (setq result (apply function arguments)) 155 (setq error nil) 156 ) 157 ) 158 (if error 159 (format t "ERROR: (~S~{ ~S~}) => ~S~%" function arguments error-value) 160 (or (eq (null result) (null expect)) 161 (format t "(~S~{ ~S~}) => should be ~A not ~A~%" 162 function arguments expect result 163 ) 164 ) 165 ) 166) 167 168(defun bool-eval (expect form &aux result (error t) unused error-value) 169 (multiple-value-setq 170 (unused error-value) 171 (ignore-errors 172 (setq result (eval form)) 173 (setq error nil) 174 ) 175 ) 176 (if error 177 (format t "ERROR: ~S => ~S~%" form error-value) 178 (or (eq (null result) (null expect)) 179 (format t "~S => should be ~A not ~A~%" 180 form expect result 181 ) 182 ) 183 ) 184) 185 186 187;; format - function 188 189;; ~c 190(format-test "A" "~C" #\A) 191(format-test " " "~C" #\Space) 192(format-test "A" "~:C" #\A) 193(format-test "Space" "~:C" #\Space) 194(format-test "#\\A" "~@C" #\A) 195(format-test "#\\Space" "~@C" #\Space) 196(format-test " " "~A" #\Space) 197(let ((*print-escape* t)) (format-test " " "~A" #\Space)) 198(format-test "#\\Space" "~S" #\Space) 199(let ((*print-escape* nil)) (format-test "#\\Space" "~S" #\Space)) 200 201;; ~% 202(format-test " 203" "~%") 204(format-test " 205 206 207" "~3%") 208 209;; ~& 210(format-test "" "~&") 211(format-test " 212" "~2&") 213 214;; ~| 215(format-test " " "~|") 216 217;; ~~ 218(format-test "~~~" "~3~") 219 220;; radix 221(format-test "1101" "~,,' ,4:B" 13) 222(format-test "1 0001" "~,,' ,4:B" 17) 223(format-test "1101 0000 0101" "~14,,' ,4:B" 3333) 224(format-test "1 22" "~3,,,' ,2:R" 17) 225(format-test "6|55|35" "~,,'|,2:D" #xFFFF) 226(format-test "1,000,000" "~,,,3:D" 1000000) 227(format-test "one hundred and twenty-three thousand, four hundred and fifty-six" 228 "~R" 123456) 229(format-test "six hundred and fifty-four thousand, three hundred twenty-first" 230 "~:R" 654321) 231(format-test "MCCXXXIV" "~@R" 1234) 232(format-test "MCCXXXXVIIII" "~@:R" 1249) 233(format-test "3039" "~X" 12345) 234(format-test "30071" "~O" 12345) 235(format-test "9IX" "~36R" 12345) 236(format-test "11000000111001" "~B" 12345) 237(format-test "The answer is 5." "The answer is ~D." 5) 238(format-test "The answer is 5." "The answer is ~3D." 5) 239(format-test "The answer is 005." "The answer is ~3,'0D." 5) 240(format-test "1111 1010 1100 1110" "~,,' ,4:B" #xFACE) 241(format-test "1 1100 1110" "~,,' ,4:B" #x1CE) 242(format-test "1111 1010 1100 1110" "~19,,' ,4:B" #xFACE) 243(format-test " 1 1100 1110" "~19,,' ,4:B" #x1CE) 244 245;; 6.37 and 6.38 are correct 246#+xedit (format-test "6.38" "~4,2F" 6.375d0) 247(format-test "10.0" "~,1F" 9.995d0) 248;; 6.37E+2 and 6.38E+2 are correct 249#+xedit (format-test " 6.38E+2" "~8,2E" 637.5) 250(do* 251 ( 252 (n '(3.14159 -3.14159 100.0 1234.0 0.006) (cdr n)) 253 (r '(" 3.14| 31.42| 3.14|3.1416|3.14|3.14159" 254 " -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159" 255 "100.00|******|100.00| 100.0|100.00|100.0" 256 "1234.00|******|??????|1234.0|1234.00|1234.0" 257 " 0.01| 0.06| 0.01| 0.006|0.01|0.006") (cdr r)) 258 (x (car n) (car n)) 259 ) 260 ((endp n)) 261 (format-test (car r) 262 "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F" x x x x x x) 263) 264(do* 265 ( 266 (n '(3.14159 -3.14159 1100.0 1.1e13 #+xedit 1.1e120) (cdr n)) 267 (r '(" 3.14E+0| 31.42$-01|+.003E+03| 3.14E+0" 268 " -3.14E+0|-31.42$-01|-.003E+03| -3.14E+0" 269 " 1.10E+3| 11.00$+02|+.001E+06| 1.10E+3" 270 "*********| 11.00$+12|+.001E+16| 1.10E+13" 271 #+xedit 272 "*********|??????????|%%%%%%%%%|1.10E+120") (cdr r)) 273 (x (car n) (car n)) 274 ) 275 ((endp n)) 276 (format-test (car r) 277 "~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~9,3,2,-2,'%@E|~9,2E" x x x x) 278) 279(do 280 ( 281 (k -5 (1+ k)) 282 (r '("Scale factor -5: | 0.000003E+06|" 283 "Scale factor -4: | 0.000031E+05|" 284 "Scale factor -3: | 0.000314E+04|" 285 "Scale factor -2: | 0.003142E+03|" 286 "Scale factor -1: | 0.031416E+02|" 287 "Scale factor 0: | 0.314159E+01|" 288 "Scale factor 1: | 3.141590E+00|" 289 "Scale factor 2: | 31.41590E-01|" 290 "Scale factor 3: | 314.1590E-02|" 291 "Scale factor 4: | 3141.590E-03|" 292 "Scale factor 5: | 31415.90E-04|" 293 "Scale factor 6: | 314159.0E-05|" 294 "Scale factor 7: | 3141590.E-06|") (cdr r)) 295 ) 296 ((endp r)) 297 (format-test (car r) "Scale factor ~2D: | ~12,6,2,VE|" k k 3.14159) 298) 299(do* 300 ( 301 (n '(0.0314159 0.314159 3.14159 31.4159 314.159 3141.59 3.14E12 302 #+xedit 3.14d120) (cdr n)) 303 (r '(" 3.14E-2|314.2$-04|0.314E-01| 3.14E-2" 304 " 0.31 |0.314 |0.314 | 0.31 " 305 " 3.1 | 3.14 | 3.14 | 3.1 " 306 " 31. | 31.4 | 31.4 | 31. " 307 " 3.14E+2| 314. | 314. | 3.14E+2" 308 " 3.14E+3|314.2$+01|0.314E+04| 3.14E+3" 309 "*********|314.0$+10|0.314E+13| 3.14E+12" 310 #+xedit "*********|?????????|%%%%%%%%%|3.14E+120") (cdr r)) 311 (x (car n) (car n)) 312 ) 313 ((endp n)) 314 (format-test (car r) "~9,2,1,,'*G|~9,3,2,3,'?,,'$G|~9,3,2,0,'%G|~9,2G" 315 x x x x) 316) 317(format-test " 1." "~4,0f" 0.5) 318(format-test " 0." "~4,0f" 0.4) 319 320;; ~p 321(setq n 3) 322(format-test "3 items found.""~D item~:P found." n) 323(format-test "three dogs are here." "~R dog~:[s are~; is~] here." n (= n 1)) 324(format-test "three dogs are here." "~R dog~:*~[s are~; is~:;s are~] here." n) 325(format-test "Here are three puppies.""Here ~[are~;is~:;are~] ~:*~R pupp~:@P." n) 326(format-test "7 tries/1 win" "~D tr~:@P/~D win~:P" 7 1) 327(format-test "1 try/0 wins" "~D tr~:@P/~D win~:P" 1 0) 328(format-test "1 try/3 wins" "~D tr~:@P/~D win~:P" 1 3) 329 330;; ~t 331(format-test " foo" "~8Tfoo") 332#+xedit (format-test " foo" "~8,3Tfoo") 333(format-test " foo" "~8,3@Tfoo") 334(format-test " foo" "~1,3@Tfoo") 335 336;; ~* 337(format-test "2" "~*~D" 1 2 3 4) 338(format-test "4" "~3*~D" 1 2 3 4) 339(format-test "2" "~3*~2:*~D" 1 2 3 4) 340(format-test "4 3 2 1 2 3 4" "~3@*~D ~2@*~D ~1@*~D ~0@*~D ~D ~D ~D" 1 2 3 4) 341 342;; ~? 343(format-test "<Foo 5> 7" "~? ~D" "<~A ~D>" '("Foo" 5) 7) 344(format-test "<Foo 5> 7" "~? ~D" "<~A ~D>" '("Foo" 5 14) 7) 345(format-test "<Foo 5> 7" "~@? ~D" "<~A ~D>" "Foo" 5 7) 346(format-test "<Foo 5> 14" "~@? ~D" "<~A ~D>" "Foo" 5 14 7) 347 348 349(format-error "~:[abc~:@(def~;ghi~:@(jkl~]mno~)" 1) 350(format-error "~?ghi~)" "abc~@(def") 351 352 353;; ~(...~) 354(format-test "XIV xiv" "~@R ~(~@R~)" 14 14) 355(format-test "Zero errors detected." "~@(~R~) error~:P detected." 0) 356(format-test "One error detected." "~@(~R~) error~:P detected." 1) 357(format-test "Twenty-three errors detected." "~@(~R~) error~:P detected." 23) 358 359;; ~[...~] 360(format-test "Persian Cat" "~[Siamese~;Manx~;Persian~] Cat" 2) 361(format-test " Cat" "~[Siamese~;Manx~;Persian~] Cat" 3) 362(format-test "Siamese Cat" "~[Siamese~;Manx~;Persian~] Cat" 0) 363(setq *print-level* nil *print-length* 5) 364(format-test " print length = 5" 365 "~@[ print level = ~D~]~@[ print length = ~D~]" *print-level* *print-length*) 366(setq foo "Items:~#[ none~; ~S~; ~S and ~S~:;~@{ ~#[~;and ~]~S~^,~}~].") 367(format-test "Items: none." foo) 368(format-test "Items: FOO." foo 'foo) 369(format-test "Items: FOO and BAR." foo 'foo 'bar) 370(format-test "Items: FOO, BAR, and BAZ." foo 'foo 'bar 'baz) 371(format-test "Items: FOO, BAR, BAZ, and QUUX." foo 'foo 'bar 'baz 'quux) 372 373;; ~{...~} 374(format-test "The winners are: FRED HARRY JILL." 375 "The winners are:~{ ~S~}." '(fred harry jill)) 376(format-test "Pairs: <A,1> <B,2> <C,3>." "Pairs:~{ <~S,~S>~}." '(a 1 b 2 c 3)) 377(format-test "Pairs: <A,1> <B,2> <C,3>." 378 "Pairs:~:{ <~S,~S>~}." '((a 1) (b 2) (c 3))) 379(format-test "Pairs: <A,1> <B,2> <C,3>." 380 "Pairs:~:@{ <~S,~S>~}." '(a 1) '(b 2) '(c 3)) 381 382;; ~<...~> 383(format-test "foo bar" "~10<foo~;bar~>") 384(format-test " foo bar" "~10:<foo~;bar~>") 385(format-test " foo bar " "~10:@<foo~;bar~>") 386(format-test " foobar" "~10<foobar~>") 387(format-test " foobar" "~10:<foobar~>") 388(format-test "foobar " "~10@<foobar~>") 389(format-test " foobar " "~10:@<foobar~>") 390 391;; ~^ 392(setq donestr "Done.~^ ~D warning~:P.~^ ~D error~:P.") 393(format-test "Done." donestr) 394(format-test "Done. 3 warnings." donestr 3) 395(format-test "Done. 1 warning. 5 errors." donestr 1 5) 396(format-test "/HOT .../HAMBURGER/ICE .../FRENCH ..." 397 "~:{/~S~^ ...~}" '((hot dog) (hamburger) (ice cream) (french fries))) 398(format-test "/HOT .../HAMBURGER .../ICE .../FRENCH" 399 "~:{/~S~:^ ...~}" '((hot dog) (hamburger) (ice cream) (french fries))) 400(format-test "/HOT .../HAMBURGER" 401 "~:{/~S~:#^ ...~}" '((hot dog) (hamburger) (ice cream) (french fries))) 402(setq tellstr "~@(~@[~R~]~^ ~A.~)") 403(format-test "Twenty-three" tellstr 23) 404(format-test " Losers." tellstr nil "losers") 405(format-test "Twenty-three losers." tellstr 23 "losers") 406(format-test " FOO" "~15<~S~;~^~S~;~^~S~>" 'foo) 407(format-test "FOO BAR" "~15<~S~;~^~S~;~^~S~>" 'foo 'bar) 408(format-test "FOO BAR BAZ" "~15<~S~;~^~S~;~^~S~>" 'foo 'bar 'baz) 409 410 411;; make-pathname - function 412(equal-test #P"/public/games/chess.db" 413 #'make-pathname :directory '(:absolute "public" "games") 414 :name "chess" :type "db") 415(equal-test #P"/etc/passwd" #'list* #P"/etc/passwd") 416(setq path (make-pathname :directory '(:absolute "public" "games") 417 :name "chess" :type "db")) 418(eq-test path #'pathname path) 419(eq-test nil #'pathname-host path) 420(eq-test nil #'pathname-device path) 421(equal-test '(:absolute "public" "games") #'pathname-directory path) 422(equal-test "chess" #'pathname-name path) 423(equal-test "db" #'pathname-type path) 424(eq-test nil #'pathname-version path) 425(equal-test #P"/tmp/foo.txt" #'make-pathname :defaults "/tmp/foo.txt") 426 427#+xedit (equal-test #P"/tmp/foo.txt" #'pathname "///tmp///foo.txt") 428;; XXX changed to remove extra separators 429;; (equal-test #P"///tmp///foo.txt" #'pathname "///tmp///foo.txt") 430 431 432;; merge-pathnames - function 433(equal-test #P"/tmp/foo.txt" #'merge-pathnames "/tmp/foo" "/tmp/foo.txt") 434(equal-test #P"/tmp/foo.txt" #'merge-pathnames "foo" "/tmp/foo.txt") 435(equal-test #P"/tmp/foo/bar.txt" #'merge-pathnames "foo/bar" "/tmp/foo.txt") 436 437;; namestring - function 438(setq path (merge-pathnames "foo/bar" "/tmp/foo.txt")) 439(equal-test "/tmp/foo/bar.txt" #'namestring path) 440(equal-test "" #'host-namestring path) 441(equal-test "/tmp/foo/" #'directory-namestring path) 442(equal-test "bar.txt" #'file-namestring path) 443(equal-test "/tmp/foo/bar.txt" #'enough-namestring path) 444(equal-test "foo/bar.txt" #'enough-namestring path "/tmp/") 445(equal-test "bar.txt" #'enough-namestring path "/tmp/foo/") 446(equal-test "foo/bar.txt" #'enough-namestring path "/tmp/foo") 447 448;; parse-namestring - function 449(equal-eval '(#P"foo" 3) '(multiple-value-list (parse-namestring "foo"))) 450(equal-eval '(#P"foo" 0) '(multiple-value-list (parse-namestring #P"foo"))) 451 452 453 454;; read - function 455(setq is (make-string-input-stream " foo ")) 456(eq-test t #'streamp is) 457(eq-test t #'input-stream-p is) 458(eq-test nil #'output-stream-p is) 459(eq-test 'foo #'read is) 460(eq-test t #'close is) 461(setq is (make-string-input-stream "xfooy" 1 4)) 462(eq-test 'foo #'read is) 463(eq-test t #'close is) 464(setq is (make-string-input-stream "")) 465(eq-test nil #'read is nil) 466(eq-test 'end-of-string #'read is nil 'end-of-string) 467(close is) 468(error-test #'read is) 469(error-test #'read is nil) 470(error-test #'read is nil 'end-of-string) 471(eq-test t #'streamp is) 472(eq-test nil #'input-stream-p is) 473(eq-test nil #'streamp "test") 474(error-test #'input-stream-p "test") 475 476;; read-char - function 477(setq is (make-string-input-stream "0123")) 478(setq test nil) 479(equal-eval '(#\0 #\1 #\2 #\3) 480 '(do ((c (read-char is) (read-char is nil 'the-end))) 481 ((not (characterp c)) test) 482 (setq test (append test (list c))))) 483(close is) 484(setq is (make-string-input-stream "abc")) 485(eql-test #\a #'read-char is) 486(eql-test #\b #'read-char is) 487(eql-test #\c #'read-char is) 488(error-test #'read-char is) 489(eq-test nil #'read-char is nil) 490(eq-test :end-of-string #'read-char is nil :end-of-string) 491(eq-test t #'close is) 492 493;; read-char-no-hang - function 494(setq is (make-string-input-stream "0123")) 495(setq test nil) 496(equal-eval '(#\0 #\1 #\2 #\3) 497 '(do ((c (read-char-no-hang is) (read-char-no-hang is nil 'the-end))) 498 ((not (characterp c)) test) 499 (setq test (append test (list c))))) 500(close is) 501(setq is (make-string-input-stream "abc")) 502(eql-test #\a #'read-char-no-hang is) 503(eql-test #\b #'read-char-no-hang is) 504(eql-test #\c #'read-char-no-hang is) 505(error-test #'read-char-no-hang is) 506(eq-test nil #'read-char-no-hang is nil) 507(eq-test :end-of-string #'read-char-no-hang is nil :end-of-string) 508(eq-test t #'close is) 509#+(and xedit unix) 510(progn 511 ;; wait one second for input pooling every 0.1 seconds 512 (defun wait-for-cat () 513 (let ((time 0.0)) 514 (loop 515 (and (listen is) (return)) 516 (sleep 0.1) 517 (when (>= (incf time 0.1) 1.0) 518 (format t "Cat is sleeping~%") 519 (return))))) 520 (setq is (make-pipe "/bin/cat" :direction :io)) 521 (equal-test "dog" #'write-line "dog" is) 522 (wait-for-cat) 523 (eql-test #\d #'read-char-no-hang is) 524 (eql-test #\o #'read-char-no-hang is) 525 (eql-test #\g #'read-char-no-hang is) 526 (eql-test #\Newline #'read-char-no-hang is) 527 (eq-test nil #'read-char-no-hang is) 528 (eq-test nil #'read-char-no-hang is) 529 (equal-test "mouse" #'write-line "mouse" is) 530 (wait-for-cat) 531 (eql-test #\m #'read-char-no-hang is) 532 (eql-test #\o #'read-char-no-hang is) 533 (eql-test #\u #'read-char-no-hang is) 534 (eql-test #\s #'read-char-no-hang is) 535 (eql-test #\e #'read-char-no-hang is) 536 (eql-test #\Newline #'read-char-no-hang is) 537 (eq-test nil #'read-char-no-hang is) 538 (eq-test t #'close is) 539 (error-test #'read-char-no-hang is) 540 (error-test #'read-char-no-hang is nil) 541 (error-test #'read-char-no-hang is nil t) 542) 543 544;; read-from-string - function 545(equal-eval '(3 5) 546 '(multiple-value-list (read-from-string " 1 3 5" t nil :start 2))) 547(equal-eval '((a b c) 7) 548 '(multiple-value-list (read-from-string "(a b c)"))) 549(error-test #'read-from-string "") 550(eq-test nil #'read-from-string "" nil) 551(eq-test 'end-of-file #'read-from-string "" nil 'end-of-file) 552 553;; read-line - function 554(setq is (make-string-input-stream "line 1 555line 2")) 556(equal-eval '("line 1" nil) '(multiple-value-list (read-line is))) 557(equal-eval '("line 2" t) '(multiple-value-list (read-line is))) 558(error-test #'read-line is) 559(equal-eval '(nil t) '(multiple-value-list (read-line is nil))) 560(equal-eval '(end-of-string t) 561 '(multiple-value-list (read-line is nil 'end-of-string))) 562 563 564;; write - function 565;; XXX several write options still missing 566(setq os (make-string-output-stream)) 567(equal-test '(1 2 3 4) #'write '(1 2 3 4) :stream os) 568(equal-test "(1 2 3 4)" #'get-output-stream-string os) 569(eq-test t #'streamp os) 570(eq-test t #'output-stream-p os) 571(eq-test nil #'input-stream-p os) 572(equal-test '(:foo :bar) #'write '(:foo :bar) :case :downcase :stream os) 573(equal-test "(:foo :bar)" #'get-output-stream-string os) 574(equal-test '(:foo :bar) #'write '(:foo :bar) :case :capitalize :stream os) 575(equal-test "(:Foo :Bar)" #'get-output-stream-string os) 576(equal-test '(:foo :bar) #'write '(:foo :bar) :case :upcase :stream os) 577(equal-test "(:FOO :BAR)" #'get-output-stream-string os) 578(equal-test '(foo bar baz) #'write '(foo bar baz) :length 2 :stream os) 579(equal-test "(FOO BAR ...)" #'get-output-stream-string os) 580(equal-test '(foo (bar) baz) #'write '(foo (bar) baz) :level 1 :stream os) 581(equal-test "(FOO # BAZ)" #'get-output-stream-string os) 582(setq circle '#1=(1 #1#)) 583(eq-test circle #'write circle :circle t :stream os) 584(equal-test "#1=(1 #1#)" #'get-output-stream-string os) 585(eql-test #\Space #'write #\Space :stream os) 586(equal-test "#\\Space" #'get-output-stream-string os) 587(eql-test #\Space #'write #\Space :escape nil :stream os) 588(equal-test " " #'get-output-stream-string os) 589(eq-test t #'close os) 590(eq-test nil #'output-stream-p os) 591(error-test #'output-stream-p "test") 592(error-test #'write 'foo :stream "bar") 593 594;; fresh-line - function 595(setq os (make-string-output-stream)) 596(equal-test "some text" #'write-string "some text" os) 597(eq-test t #'fresh-line os) 598(eq-test nil #'fresh-line os) 599(equal-test "more text" #'write-string "more text" os) 600(equal-test "some text 601more text" #'get-output-stream-string os) 602(equal-test nil #'fresh-line os) 603(equal-test nil #'fresh-line os) 604(equal-test "" #'get-output-stream-string os) 605(close os) 606(error-test #'fresh-line 1) 607 608;; prin1 - function 609;; (prin1 object stream) == 610;; (write object :stream stream :escape t) 611(setq p-os (make-string-output-stream) w-os (make-string-output-stream)) 612(dolist (object (list #\a 1 "string" 2.5d0 '(a . b) '(a b c) #P"foo" 613 *package* *standard-input* #c(1 2) #(1 2 3) 614 (make-hash-table))) 615 (eq-test object #'prin1 object p-os) 616 (eq-test object #'write object :stream w-os :escape t) 617 (equal-test (get-output-stream-string p-os) 618 #'get-output-stream-string w-os)) 619(close p-os) 620(close w-os) 621(error-test #'prin1 1 1) 622 623;; princ - function 624;; (princ object stream) == 625;; (write object :stream stream :escape nil :readably nil) 626;; XXX readably not yet implemented 627(setq p-os (make-string-output-stream) w-os (make-string-output-stream)) 628(dolist (object (list #\a 1 "string" 2.5d0 '(a . b) '(a b c) #P"foo" 629 *package* *standard-input* #c(1 2) #(1 2 3) 630 (make-hash-table))) 631 (eq-test object #'princ object p-os) 632 (eq-test object #'write object :stream w-os :escape nil) 633 (equal-test (get-output-stream-string p-os) 634 #'get-output-stream-string w-os)) 635(close p-os) 636(close w-os) 637(error-test #'princ 1 1) 638 639;; print - function 640;; (print object stream) == 641;; (progn 642;; (terpri stream) 643;; (write object :stream stream :escape t) 644;; (write-char #\Space stream)) 645(setq p-os (make-string-output-stream) w-os (make-string-output-stream)) 646(dolist (object (list #\a 1 "string" 2.5d0 '(a . b) '(a b c) #P"foo" 647 *package* *standard-input* #c(1 2) #(1 2 3) 648 (make-hash-table))) 649 (eq-test object #'print object p-os) 650 (progn 651 (eq-test nil #'terpri w-os) 652 (eq-test object #'write object :stream w-os :escape t) 653 (eql-test #\Space #'write-char #\Space w-os)) 654 (equal-test (get-output-stream-string p-os) 655 #'get-output-stream-string w-os)) 656(close p-os) 657(close w-os) 658(error-test #'print 1 1) 659 660;; terpri - function 661(setq os (make-string-output-stream)) 662(equal-test "some text" #'write-string "some text" os) 663(eq-test nil #'terpri os) 664(eq-test nil #'terpri os) 665(equal-test "more text" #'write-string "more text" os) 666(equal-test "some text 667 668more text" #'get-output-stream-string os) 669(equal-test nil #'terpri os) 670(equal-test nil #'terpri os) 671(equal-test " 672 673" #'get-output-stream-string os) 674(close os) 675(error-test #'terpri 1) 676 677;; write-char - function 678(equal-eval "a b" 679 '(with-output-to-string (s) 680 (write-char #\a s) 681 (write-char #\Space s) 682 (write-char #\b s))) 683(error-test #'write-char 1) 684 685;; write-line - function 686(setq os (make-string-output-stream)) 687(equal-test "text" #'write-line "text" os) 688(equal-test "text 689" #'get-output-stream-string os) 690(eql-test #\< #'write-char #\< os) 691(equal-test "text" #'write-line "text" os :start 1 :end 3) 692(eql-test #\> #'write-char #\> os) 693(equal-test "<ex 694>" #'get-output-stream-string os) 695(error-test #'write-line 1) 696(close os) 697 698;; write-string - function 699(setq os (make-string-output-stream)) 700(equal-test "text" #'write-string "text" os) 701(equal-test "text" #'get-output-stream-string os) 702(eql-test #\< #'write-char #\< os) 703(equal-test "text" #'write-string "text" os :start 1 :end 3) 704(eql-test #\> #'write-char #\> os) 705(equal-test "<ex>" #'get-output-stream-string os) 706(error-test #'write-string #\a) 707(close os) 708 709 710;; open - function 711(setq name #P"delete-me.text") 712(bool-eval t '(setq file (open name :direction :output))) 713(equal-test "some text" #'write-line "some text" file) 714(close file) 715(equal-test "delete-me.text" #'file-namestring (truename name)) 716(setq file (open name :direction :output :if-exists :rename)) 717(equal-test "other text" #'write-line "other text" file) 718(close file) 719(equal-test "delete-me.text" #'file-namestring (truename name)) 720;; Clisp returns the pathname if the file exists 721#+xedit (eq-test t #'delete-file name) 722#+clisp (bool-test t #'delete-file name) 723(setq backup 724 #+xedit "delete-me.text~" 725 #+clisp "delete-me.text%" 726 #+cmu "delete-me.text.BAK") 727(bool-test t #'delete-file backup) 728(eq-test nil #'delete-file name) 729(eq-test nil #'directory name) 730(eq-test nil #'directory backup) 731;; test append 732(with-open-file (s name :direction :output :if-exists :error) 733 (write-line "line 1" s)) 734(with-open-file (s name :direction :output :if-exists :append) 735 (write-line "line 2" s)) 736(with-open-file (s name :direction :input) 737 (equal-test "line 1" #'read-line s) 738 (equal-test "line 2" #'read-line s) 739 (eq-test 'eof #'read-line s nil 'eof) 740) 741(bool-test t #'delete-file name) 742;; test overwrite 743(with-open-file (s name :direction :output :if-exists :error) 744 (write-line "overwrite-me" s)) 745(with-open-file (s name :direction :output :if-exists :overwrite) 746 (write-line "some-text" s)) 747(with-open-file (s name :direction :input) 748 (equal-test "some-text" #'read-line s) 749 (eq-test 'eof #'read-line s nil 'eof)) 750;; test check for file existence 751(eq-test nil #'open name :direction :output :if-exists nil) 752(error-test #'open name :direction :output :if-exists :error) 753(bool-test t #'delete-file name) 754;; test check for no file existence 755(eq-test nil #'open name :direction :output :if-does-not-exist nil) 756(error-test #'open name :direction :output :if-does-not-exist :error) 757#+xedit ;; test io -- not sure if this is the expected behaviour 758(progn 759 (with-open-file (s name :direction :io) 760 (write-line "foo" s) 761 (write-line "bar" s)) 762 (with-open-file (s name :direction :io :if-exists :append) 763 (equal-test "foo" #'read-line s) 764 (equal-test "bar" #'read-line s) 765 (eq-test 'eof #'read-line s nil 'eof) 766 (write-line "baz" s)) 767 (with-open-file (s name :direction :io :if-exists :append) 768 (equal-test "foo" #'read-line s) 769 (equal-test "bar" #'read-line s) 770 (equal-test "baz" #'read-line s) 771 (eq-test 'eof #'read-line s nil 'eof)) 772 (bool-test t #'delete-file name) 773) 774 775;; delete-file - function 776(eq-eval nil 777 '(with-open-file (s "delete-me.text" :direction :output :if-exists :error))) 778(eq-test t #'pathnamep (setq p (probe-file "delete-me.text"))) 779(bool-test t #'delete-file p) 780(eq-test nil #'probe-file "delete-me.text") 781(bool-eval t 782 '(with-open-file (s "delete-me.text" :direction :output :if-exists :error) 783 (delete-file s))) 784(bool-test nil #'probe-file "delete-me.text") 785 786;; rename-file - function 787(setq name "foo.bar") 788(bool-eval t '(setq file (open name :direction :output :if-exists :error))) 789(eq-test t #'close file) 790(setq result (multiple-value-list (rename-file name "bar.foo"))) 791(eql-test 3 #'length result) 792(eq-test t #'pathnamep (first result)) 793(eq-test t #'pathnamep (second result)) 794(eq-test t #'pathnamep (third result)) 795(equal-test (third result) #'truename "bar.foo") 796(eq-test nil #'directory name) 797(eq-test nil #'directory (second result)) 798(equal-test (list (third result)) #'directory (third result)) 799(error-test #'truename name) 800(error-test #'truename (second result)) 801(eq-test nil #'probe-file name) 802(bool-test t #'probe-file (first result)) 803(eq-test nil #'probe-file (second result)) 804(bool-test t #'probe-file (third result)) 805(bool-test t #'delete-file "bar.foo") 806(eq-test nil #'delete-file (third result)) 807(eq-test nil #'delete-file (second result)) 808