1#!core
2;;; Ypsilon Scheme System
3;;; Copyright (c) 2004-2008 Y.FUJITA, LittleWing Company Limited.
4;;; See license.txt for terms and conditions of use.
5
6(library (core io assistants)
7
8  (export port-type
9          port-direction
10          port-lookup-file-option-code
11          port-lookup-buffer-mode-code
12          port-lookup-codec-code
13          port-lookup-eol-style-code
14          port-lookup-error-handling-mode-code
15          port-reverse-lookup-codec-code
16          port-reverse-lookup-eol-style-code
17          port-reverse-lookup-error-handling-mode-code
18          make-file-options)
19
20  (import (core primitives) (core enums))
21
22  (define direction-codes
23    '((input . 1) (output . 2) (input/output . 3)))
24
25  (define type-codes
26    '((file . 1) (bytevector . 2) (custom . 3)))
27
28  (define file-option-codes
29    '((no-create . 1) (no-fail . 2) (no-truncate . 4)))
30
31  (define buffer-mode-codes
32    '((none . 1) (line . 2) (block . 3)))
33
34  (define codec-codes
35    '((latin-1 . 1) (utf-8 . 2) (utf-16 . 3)))
36
37  (define eol-style-codes
38    '((none . 1) (lf . 2) (cr . 3) (crlf . 4) (nel . 5) (crnel . 6) (ls . 7)))
39
40  (define error-handling-mode-codes
41    '((ignore . 1) (raise . 2) (replace . 3)))
42
43  (define flip (lambda (lst) (map (lambda (e) (cons (cdr e) (car e))) lst)))
44
45  (define flipped-codec-codes (flip codec-codes))
46
47  (define flipped-eol-style-codes (flip eol-style-codes))
48
49  (define flipped-error-handling-mode-codes (flip error-handling-mode-codes))
50
51  (define lookup (lambda (obj alist) (cond ((assq obj alist) => cdr) (else #f))))
52
53  (define-syntax port-type
54    (lambda (x)
55      (syntax-case x ()
56        ((_ type)
57         (datum->syntax
58          #'k
59          (cond ((assq (syntax->datum (syntax type)) type-codes) => cdr)
60                (else
61                 (syntax-violation 'port-type "invalid port type" x)))))
62        (_
63         (syntax-violation 'port-type "invalid port type" x)))))
64
65  (define-syntax port-direction
66    (lambda (x)
67      (syntax-case x (input output)
68        ((_ input)
69         (datum->syntax #'k (lookup 'input direction-codes)))
70        ((_ output)
71         (datum->syntax #'k (lookup 'output direction-codes)))
72        ((_ input output)
73         (datum->syntax #'k (lookup 'input/output direction-codes)))
74        (_
75         (syntax-violation 'port-direction "invalid port direction" x)))))
76
77  (define port-lookup-file-option-code (lambda (obj) (lookup obj file-option-codes)))
78  (define port-lookup-buffer-mode-code (lambda (obj) (lookup obj buffer-mode-codes)))
79  (define port-lookup-codec-code (lambda (obj) (lookup obj codec-codes)))
80  (define port-lookup-eol-style-code (lambda (obj) (lookup obj eol-style-codes)))
81  (define port-lookup-error-handling-mode-code (lambda (obj) (lookup obj error-handling-mode-codes)))
82  (define port-reverse-lookup-codec-code (lambda (obj) (lookup obj flipped-codec-codes)))
83  (define port-reverse-lookup-eol-style-code (lambda (obj) (lookup obj flipped-eol-style-codes)))
84  (define port-reverse-lookup-error-handling-mode-code (lambda (obj) (lookup obj flipped-error-handling-mode-codes)))
85
86  (define make-file-options (enum-set-constructor (make-enumeration (map car file-option-codes))))
87
88  )
89
90(library (core io)
91
92  (export file-options
93          buffer-mode
94          buffer-mode?
95          utf-8-codec
96          utf-16-codec
97          latin-1-codec
98          eol-style
99          error-handling-mode
100          make-transcoder
101          transcoder-codec
102          transcoder-eol-style
103          transcoder-error-handling-mode
104          native-transcoder
105          native-eol-style
106          bytevector->string
107          string->bytevector
108          eof-object
109          eof-object?
110          port?
111          port-transcoder
112          textual-port?
113          binary-port?
114          transcoded-port
115          port-has-port-position?
116          port-position
117          port-has-set-port-position!?
118          set-port-position!
119
120          close-port
121          call-with-port
122          input-port?
123          port-eof?
124
125          open-file-input-port
126          open-bytevector-input-port
127          open-string-input-port
128          standard-input-port
129          current-input-port
130
131          get-u8
132          lookahead-u8
133          get-bytevector-n
134          get-bytevector-n!
135          get-bytevector-some
136          get-bytevector-all
137
138          get-char
139          lookahead-char
140          get-string-n
141          get-string-n!
142          get-string-all
143          get-line
144          get-datum
145
146          output-port?
147          flush-output-port
148          output-port-buffer-mode
149          open-file-output-port
150          open-bytevector-output-port
151          call-with-bytevector-output-port
152          open-string-output-port
153          call-with-string-output-port
154          standard-output-port
155          standard-error-port
156          current-output-port
157          current-error-port
158
159          put-u8
160          put-bytevector
161          put-char
162          put-string
163          put-datum
164
165          open-file-input/output-port
166
167          ; io simple
168          call-with-input-file
169          call-with-output-file
170          with-input-from-file
171          with-output-to-file
172          open-input-file
173          open-output-file
174          close-input-port
175          close-output-port
176          read-char
177          peek-char
178          read
179          write-char
180          newline
181          display
182          write
183
184          make-custom-binary-input-port
185          make-custom-textual-input-port
186          make-custom-binary-output-port
187          make-custom-textual-output-port
188          make-custom-binary-input/output-port
189          make-custom-textual-input/output-port
190
191          &i/o make-i/o-error i/o-error?
192          &i/o-read make-i/o-read-error i/o-read-error?
193          &i/o-write make-i/o-write-error i/o-write-error?
194          &i/o-invalid-position make-i/o-invalid-position-error i/o-invalid-position-error? i/o-error-position
195          &i/o-filename make-i/o-filename-error i/o-filename-error? i/o-error-filename
196          &i/o-file-protection make-i/o-file-protection-error i/o-file-protection-error?
197          &i/o-file-is-read-only make-i/o-file-is-read-only-error i/o-file-is-read-only-error?
198          &i/o-file-already-exists make-i/o-file-already-exists-error i/o-file-already-exists-error?
199          &i/o-file-does-not-exist make-i/o-file-does-not-exist-error i/o-file-does-not-exist-error?
200          &i/o-port make-i/o-port-error i/o-port-error? i/o-error-port
201
202          &i/o-decoding make-i/o-decoding-error i/o-decoding-error?
203          &i/o-encoding make-i/o-encoding-error i/o-encoding-error? i/o-encoding-error-char
204
205          open-temporary-file-port
206          format)
207
208  (import (core io assistants)
209          (core primitives)
210          (core syntax-case)
211          (core lists)
212          (core conditions)
213          (core bytevectors)
214          (core optargs)
215          (core chkarg)
216          (core enums))
217
218  ;; 8.2.2  File options
219
220  (define-syntax file-options
221    (lambda (x)
222      (syntax-case x ()
223        ((_ options ...)
224         (let ((lst (syntax->datum (syntax (options ...)))))
225           (or (and (list-of-unique-symbols? lst) (for-all port-lookup-file-option-code lst))
226               (syntax-violation 'file-options "invalid option" x))
227           (syntax (make-file-options '(options ...)))))
228        (_
229         (syntax-violation 'file-options "invalid syntax" x)))))
230
231  (define file-options->bits
232    (lambda (x)
233      (apply + (map (lambda (e) (port-lookup-file-option-code e)) (enum-set->list x)))))
234
235  ;; 8.2.3  Buffer modes
236
237  (define-syntax buffer-mode
238    (lambda (x)
239      (syntax-case x ()
240        ((_ mode)
241         (or (port-lookup-buffer-mode-code (syntax->datum (syntax mode)))
242             (syntax-violation 'buffer-mode "invalid buffer mode" x))
243         (syntax 'mode))
244        (_
245         (syntax-violation 'buffer-mode "invalid buffer mode" x)))))
246
247  (define buffer-mode?
248    (lambda (mode)
249      (and (port-lookup-buffer-mode-code mode) #t)))
250
251  ;; 8.2.4  Transcoders
252
253  (define predefined-utf-8-codec (tuple 'type:codec 'utf-8))
254  (define predefined-utf-16-codec (tuple 'type:codec 'utf-16))
255  (define predefined-latin-1-codec (tuple 'type:codec 'latin-1))
256
257  (define utf-8-codec (lambda () predefined-utf-8-codec))
258  (define utf-16-codec (lambda () predefined-utf-16-codec))
259  (define latin-1-codec (lambda () predefined-latin-1-codec))
260
261  (define-syntax eol-style
262    (lambda (x)
263      (syntax-case x ()
264        ((_ style)
265         (or (port-lookup-eol-style-code (syntax->datum (syntax style)))
266             (syntax-violation 'eol-style "invalid eol style" x))
267         (syntax 'style))
268        (_
269         (syntax-violation 'eol-style "invalid eol style" x)))))
270
271  (define-syntax error-handling-mode
272    (lambda (x)
273      (syntax-case x ()
274        ((_ mode)
275         (or (port-lookup-error-handling-mode-code (syntax->datum (syntax mode)))
276             (syntax-violation 'error-handling-mode "invalid directive" x))
277         (syntax 'mode))
278        (_
279         (syntax-violation 'error-handling-mode "invalid directive" x)))))
280
281  (define make-transcoder
282    (lambda (codec . options)
283      (let-optionals options ((eol-style (native-eol-style)) (error-handling-mode 'replace))
284        (let ((bv (make-bytevector 3)))
285          (bytevector-u8-set! bv 0 (port-lookup-codec-code (tuple-ref codec 1)))
286          (bytevector-u8-set! bv 1 (port-lookup-eol-style-code eol-style))
287          (bytevector-u8-set! bv 2 (port-lookup-error-handling-mode-code error-handling-mode))
288          (tuple 'type:transcoder bv)))))
289
290  (define transcoder-descriptor
291    (lambda (transcoder)
292      (tuple-ref transcoder 1)))
293
294  (define transcoder-codec
295    (lambda (transcoder)
296      (case (port-reverse-lookup-codec-code (bytevector-u8-ref (transcoder-descriptor transcoder) 0))
297        ((latin-1) (latin-1-codec))
298        ((utf-8) (utf-8-codec))
299        ((utf-16) (utf-16-codec)))))
300
301  (define transcoder-eol-style
302    (lambda (transcoder)
303      (port-reverse-lookup-eol-style-code (bytevector-u8-ref (transcoder-descriptor transcoder) 1))))
304
305  (define transcoder-error-handling-mode
306    (lambda (transcoder)
307      (port-reverse-lookup-error-handling-mode-code (bytevector-u8-ref (transcoder-descriptor transcoder) 2))))
308
309  (define native-transcoder
310    (let ((transcoder (tuple 'type:transcoder (native-transcoder-descriptor))))
311      (lambda () transcoder)))
312
313  (define native-eol-style (lambda () (transcoder-eol-style (native-transcoder))))
314
315  (define bytevector->string
316    (lambda (bytes transcoder)
317      (let-values (((out extract) (open-string-output-port)))
318          (call-with-port
319           (open-bytevector-input-port bytes transcoder)
320           (lambda (in)
321             (let loop ((c (get-char in)))
322               (cond ((eof-object? c) (extract))
323                     (else
324                      (put-char out c)
325                      (loop (get-char in))))))))))
326
327 #; (define string->bytevector
328    (lambda (string transcoder)
329      (let-values (((out extract) (open-bytevector-output-port transcoder)))
330        (call-with-port
331         (open-string-input-port string)
332         (lambda (in)
333           (let loop ((c (get-char in)))
334             (cond ((eof-object? c) (extract))
335                   (else
336                    (put-char out c)
337                    (loop (get-char in))))))))))
338
339  (define string->bytevector
340    (lambda (string transcoder)
341      (let-values (((out extract) (open-bytevector-output-port transcoder)))
342        (call-with-port
343         (make-string-input-port string)
344         (lambda (in)
345           (let loop ((c (get-char in)))
346             (cond ((eof-object? c) (extract))
347                   (else
348                    (put-char out c)
349                    (loop (get-char in))))))))))
350
351  ;; 8.2.6  Input and output ports
352
353  (define port-transcoder
354    (lambda (port)
355      (let ((desc (port-transcoder-descriptor port)))
356        (and desc
357             (if (eq? desc #t)
358                 (native-transcoder)
359                 (tuple 'type:transcoder desc))))))
360
361  (define textual-port?
362    (lambda (port)
363      (and (port-transcoder-descriptor port) #t)))
364
365  (define binary-port?
366    (lambda (port)
367      (not (port-transcoder-descriptor port))))
368
369  (define transcoded-port
370    (lambda (port transcoder)
371      (make-transcoded-port port (transcoder-descriptor transcoder))))
372
373  ;; 8.2.7  Input ports
374
375  (define open-file-input-port
376    (lambda (filename . options)
377      (let-optionals options
378          ((file-options (file-options))
379           (buffer-mode 'block)
380           (transcoder #f))
381        (open-port (port-type file)
382                   (port-direction input)
383                   filename
384                   (file-options->bits file-options)
385                   (port-lookup-buffer-mode-code buffer-mode)
386                   (and transcoder (transcoder-descriptor transcoder))))))
387
388  (define open-bytevector-input-port
389    (lambda (bytes . options)
390      (let-optionals options ((transcoder #f))
391        (open-port (port-type bytevector)
392                   (port-direction input)
393                   'bytevector
394                   bytes
395                   #f
396                   (and transcoder (transcoder-descriptor transcoder))))))
397
398  (define open-string-input-port
399    (lambda (string)
400      (make-string-input-port string)))
401
402  (define make-custom-binary-input-port
403    (lambda (id read! get-position set-position! close)
404      (open-port (port-type custom)
405                 (port-direction input)
406                 id
407                 (vector #f read! #f get-position set-position! close)
408                 #f
409                 #f)))
410
411  (define make-custom-textual-input-port
412    (lambda (id read! get-position set-position! close)
413      (define port)
414
415      (define ht-token (make-core-hashtable 'eqv?))
416
417      (define bv-read!
418        (lambda (bv start count)
419          (cond ((= count 0) 0)
420                (else
421                 (let* ((len (div count 4))
422                        (str (make-string len #\nul))
423                        (count (read! str 0 len)))
424                   (cond ((= count 0) 0)
425                         (else
426                          (let* ((bv-utf8 (string->utf8 (substring str 0 count)))
427                                 (count (bytevector-length bv-utf8)))
428                            (bytevector-copy! bv-utf8 0 bv start count)
429                            count))))))))
430
431      (define bv-get-position
432        (lambda (token)
433          (core-hashtable-set! ht-token token (get-position))
434          token))
435
436      (define bv-set-position!
437        (lambda (token)
438          (cond ((core-hashtable-ref ht-token token #f)
439                 => (lambda (pos) (set-position! pos)))
440                ((warning-level)
441                 (format (current-error-port) "~&warning in set-port-position: expected return value of a call to get-position, but got ~u~%~!" token)
442                 (set-position! token))
443                (else
444                 (set-position! token)))))
445
446      (set! port (open-port (port-type custom)
447                            (port-direction input)
448                            id
449                            (vector #t (and read! bv-read!) #f (and get-position bv-get-position) (and set-position! bv-set-position!) close)
450                            #f
451                            #t))
452      port))
453
454  ;; 8.2.10  Output ports
455
456  (define open-file-output-port
457    (lambda (filename . options)
458      (let-optionals options
459          ((file-options (file-options))
460           (buffer-mode 'block)
461           (transcoder #f))
462        (open-port (port-type file)
463                   (port-direction output)
464                   filename
465                   (file-options->bits file-options)
466                   (port-lookup-buffer-mode-code buffer-mode)
467                   (and transcoder (transcoder-descriptor transcoder))))))
468
469  (define bytevector-output-port-values
470    (lambda (port)
471      (values port (lambda () (extract-accumulated-bytevector port)))))
472
473  (define open-bytevector-output-port
474    (lambda options
475      (let-optionals options ((transcoder #f))
476        (bytevector-output-port-values
477         (open-port (port-type bytevector)
478                    (port-direction output)
479                    'bytevector
480                    #f
481                    #f
482                    (and transcoder (transcoder-descriptor transcoder)))))))
483
484  (define call-with-bytevector-output-port
485    (lambda (proc . options)
486      (let-optionals options ((transcoder #f))
487        (let-values (((port extractor) (open-bytevector-output-port transcoder)))
488          (dynamic-wind
489           (lambda () #f)
490           (lambda () (proc port) (extractor))
491           (lambda () (close-port port)))))))
492
493  (define call-with-string-output-port
494    (lambda (proc)
495      (let-values (((port extractor) (open-string-output-port)))
496        (dynamic-wind
497         (lambda () #f)
498         (lambda () (proc port) (extractor))
499         (lambda () (close-port port))))))
500
501  (define string-output-port-values
502    (lambda (port)
503      (values port (lambda () (extract-accumulated-string port)))))
504
505  (define open-string-output-port
506    (lambda ()
507      (string-output-port-values (make-string-output-port))))
508
509  (define make-custom-binary-output-port
510    (lambda (id write! get-position set-position! close)
511      (open-port (port-type custom)
512                 (port-direction output)
513                 id
514                 (vector #f #f write! get-position set-position! close)
515                 #f
516                 #f)))
517
518  (define make-custom-textual-output-port
519    (lambda (id write! get-position set-position! close)
520
521      (define port)
522
523      (define ht-token (make-core-hashtable 'eqv?))
524
525      (define bv-write!
526        (lambda (bv start count)
527          (cond ((= count 0) (write! "" 0 0) 0)
528                (else
529                 (let ((bv-utf8 (make-bytevector count)))
530                   (bytevector-copy! bv start bv-utf8 0 count)
531                   (let* ((str (utf8->string bv-utf8))
532                          (len (string-length str)))
533                     (let ((written (write! str 0 len)))
534                       (bytevector-length (string->utf8 (substring str 0 written))))))))))
535
536      (define bv-get-position
537        (lambda (token)
538          (core-hashtable-set! ht-token token (get-position))
539          token))
540
541      (define bv-set-position!
542        (lambda (token)
543          (cond ((core-hashtable-ref ht-token token #f)
544                 => (lambda (pos) (set-position! pos)))
545                ((warning-level)
546                 (format (current-error-port) "~&warning in set-port-position: expected return value of a call to get-position, but got ~u~%~!" token)
547                 (set-position! token))
548                (else
549                 (set-position! token)))))
550
551      (set! port (open-port (port-type custom)
552                            (port-direction output)
553                            id
554                            (vector #t #f (and write! bv-write!) (and get-position bv-get-position) (and set-position! bv-set-position!) close)
555                            #f
556                            #t))
557      port))
558
559  ;; 8.2.13  Input/output ports
560
561  (define open-file-input/output-port
562    (lambda (filename . options)
563      (let-optionals options
564          ((file-options (file-options))
565           (buffer-mode 'block)
566           (transcoder #f))
567        (open-port (port-type file)
568                   (port-direction input output)
569                   filename
570                   (file-options->bits file-options)
571                   (port-lookup-buffer-mode-code buffer-mode)
572                   (and transcoder (transcoder-descriptor transcoder))))))
573
574  (define make-custom-binary-input/output-port
575    (lambda (id read! write! get-position set-position! close)
576      (open-port (port-type custom)
577                 (port-direction input output)
578                 id
579                 (vector #f read! write! get-position set-position! close)
580                 #f
581                 #f)))
582
583  (define make-custom-textual-input/output-port
584    (lambda (id read! write! get-position set-position! close)
585
586      (define port)
587
588      (define ht-token (make-core-hashtable 'eqv?))
589
590      (define bv-read!
591        (lambda (bv start count)
592          (cond ((= count 0) 0)
593                (else
594                 (let* ((len (div count 4))
595                        (str (make-string len #\nul))
596                        (count (read! str 0 len)))
597                   (cond ((= count 0) 0)
598                         (else
599                          (let* ((bv-utf8 (string->utf8 (substring str 0 count)))
600                                 (count (bytevector-length bv-utf8)))
601                            (bytevector-copy! bv-utf8 0 bv start count)
602                            count))))))))
603
604      (define bv-write!
605        (lambda (bv start count)
606          (cond ((= count 0) (write! "" 0 0) 0)
607                (else
608                 (let ((bv-utf8 (make-bytevector count)))
609                   (bytevector-copy! bv start bv-utf8 0 count)
610                   (let* ((str (utf8->string bv-utf8))
611                          (len (string-length str)))
612                     (let ((written (write! str 0 len)))
613                       (bytevector-length (string->utf8 (substring str 0 written))))))))))
614
615      (define bv-get-position
616        (lambda (token)
617          (core-hashtable-set! ht-token token (get-position))
618          token))
619
620      (define bv-set-position!
621        (lambda (token)
622          (cond ((core-hashtable-ref ht-token token #f)
623                 => (lambda (pos) (set-position! pos)))
624                ((warning-level)
625                 (format (current-error-port) "~&warning in set-port-position: expected return value of a call to get-position, but got ~u~%~!" token)
626                 (set-position! token))
627                (else
628                 (set-position! token)))))
629
630      (set! port (open-port (port-type custom)
631                            (port-direction input output)
632                            id
633                            (vector #t (and read! bv-read!) (and write! bv-write!) (and get-position bv-get-position) (and set-position! bv-set-position!) close)
634                            #f
635                            #t))
636      port))
637
638  ;; 8.3  Simple I/O
639
640  (define call-with-input-file
641    (lambda (filename proc)
642      (call-with-port (open-input-file filename) proc)))
643
644  (define call-with-output-file
645    (lambda (filename proc)
646      (call-with-port (open-output-file filename) proc)))
647
648  (define with-input-from-file
649    (lambda (filename thunk)
650      (let ((port (open-input-file filename)) (save (current-input-port)))
651        (dynamic-wind
652         (lambda () (set-current-input-port! port))
653         (lambda () (let ((ans (thunk))) (close-input-port port) ans))
654         (lambda () (set-current-input-port! save))))))
655
656  (define with-output-to-file
657    (lambda (filename thunk)
658      (let ((port (open-output-file filename)) (save (current-output-port)))
659        (dynamic-wind
660         (lambda () (set-current-output-port! port))
661         (lambda () (let ((ans (thunk))) (close-output-port port) ans))
662         (lambda () (set-current-output-port! save))))))
663
664  (define open-input-file
665    (lambda (filename)
666      (open-file-input-port filename (file-options) (buffer-mode block) (native-transcoder))))
667
668  (define open-output-file
669    (lambda (filename)
670      (open-file-output-port filename (file-options) (buffer-mode block) (native-transcoder))))
671
672  (define close-input-port
673    (lambda (port)
674      (close-port port)))
675
676  (define close-output-port
677    (lambda (port)
678      (close-port port)))
679
680  ;; extension
681
682  (define open-temporary-file-port
683    (lambda options
684      (let-optionals options ((name "temporary file") (transcoder #f))
685        (make-temporary-file-port name (and transcoder (transcoder-descriptor transcoder))))))
686
687  ) ;[end]
688