~ chicken-core (master) /port.scm

  1;;; port.scm - Optional non-standard ports
  2;
  3; Copyright (c) 2008-2022, The CHICKEN Team
  4; Copyright (c) 2000-2007, Felix L. Winkelmann
  5; All rights reserved.
  6;
  7; Redistribution and use in source and binary forms, with or without
  8; modification, are permitted provided that the following conditions
  9; are met:
 10;
 11;   Redistributions of source code must retain the above copyright
 12;   notice, this list of conditions and the following disclaimer.
 13;   Redistributions in binary form must reproduce the above copyright
 14;   notice, this list of conditions and the following disclaimer in
 15;   the documentation and/or other materials provided with the
 16;   distribution.
 17;   Neither the name of the author nor the names of its contributors
 18;   may be used to endorse or promote products derived from this
 19;   software without specific prior written permission.
 20;
 21; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
 22; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
 23; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
 24; FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
 25; COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
 26; INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
 27; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 28; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
 29; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
 30; STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
 31; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
 32; OF THE POSSIBILITY OF SUCH DAMAGE.
 33
 34
 35(declare
 36  (unit port)
 37  (uses extras))
 38
 39(module chicken.port
 40  (call-with-input-string
 41   call-with-output-string
 42   copy-port
 43   make-input-port make-binary-input-port
 44   make-output-port make-binary-output-port
 45   port-encoding
 46   port-fold
 47   port-for-each
 48   port-map
 49   port-name
 50   port-position
 51   make-bidirectional-port
 52   make-broadcast-port
 53   make-concatenated-port
 54   set-buffering-mode!
 55   terminal-name
 56   terminal-port?
 57   terminal-size
 58   with-error-output-to-port
 59   with-input-from-port
 60   with-input-from-string
 61   with-output-to-port
 62   with-output-to-string
 63   with-error-output-to-string)
 64
 65(import scheme
 66	chicken.base
 67	chicken.fixnum
 68	chicken.foreign
 69	chicken.io)
 70(import (only (scheme base) open-output-string get-output-string open-input-string u8-ready?))
 71
 72(include "common-declarations.scm")
 73
 74#>
 75
 76#if !defined(_WIN32)
 77# include <sys/ioctl.h>
 78# include <termios.h>
 79#endif
 80
 81#if !defined(__ANDROID__) && defined(TIOCGWINSZ)
 82static int get_tty_size(int fd, int *rows, int *cols)
 83{
 84  struct winsize tty_size;
 85  int r;
 86
 87  memset(&tty_size, 0, sizeof tty_size);
 88
 89  r = ioctl(fd, TIOCGWINSZ, &tty_size);
 90  if (r == 0) {
 91     *rows = tty_size.ws_row;
 92     *cols = tty_size.ws_col;
 93  }
 94  return r;
 95}
 96#else
 97static int get_tty_size(int fd, int *rows, int *cols)
 98{
 99  *rows = *cols = 0;
100  errno = ENOSYS;
101  return -1;
102}
103#endif
104
105#if defined(_WIN32) && !defined(__CYGWIN__)
106char *ttyname(int fd) {
107  errno = ENOSYS;
108  return NULL;
109}
110#endif
111
112<#
113
114
115(define-foreign-variable _iofbf int "_IOFBF")
116(define-foreign-variable _iolbf int "_IOLBF")
117(define-foreign-variable _ionbf int "_IONBF")
118(define-foreign-variable _bufsiz int "BUFSIZ")
119
120(define port-encoding
121  (getter-with-setter
122    (lambda (port)
123      (##sys#check-port port 'port-encoding)
124      (##sys#slot port 15))
125    (lambda (port enc)
126      (##sys#check-port port 'port-encoding)
127      (##sys#check-symbol enc 'port-encoding)
128      (##sys#setslot port 15 enc))
129    "(chicken.port#port-encoding port)"))
130
131(define port-name
132  (getter-with-setter
133    (lambda (#!optional (port ##sys#standard-input))
134      (##sys#check-port port 'port-name)
135      (##sys#slot port 3))
136    (lambda (port name)
137      (##sys#check-port port 'set-port-name!)
138      (##sys#check-string name 'set-port-name!)
139      (##sys#setslot port 3 name))
140    "(chicken.port#port-name port)"))
141
142(define (port-position #!optional (port ##sys#standard-input))
143  (##sys#check-port port 'port-position)
144  (if (##core#inline "C_input_portp" port)
145      (##sys#values (##sys#slot port 4) (##sys#slot port 5))
146      (##sys#error 'port-position "cannot compute position of port" port)))
147
148(define (set-buffering-mode! port mode . size)
149  (##sys#check-port port 'set-buffering-mode!)
150  (let ((size (if (pair? size) (car size) _bufsiz))
151	(mode (case mode
152		((#:full) _iofbf)
153		((#:line) _iolbf)
154		((#:none) _ionbf)
155		(else (##sys#error 'set-buffering-mode! "invalid buffering-mode" mode port)))))
156    (##sys#check-fixnum size 'set-buffering-mode!)
157    (when (fx< (if (eq? 'stream (##sys#slot port 7))
158		   ((foreign-lambda* int ((scheme-object p) (int m) (int s))
159		     "C_return(setvbuf(C_port_file(p), NULL, m, s));")
160		    port mode size)
161		   -1)
162	       0)
163      (##sys#error 'set-buffering-mode! "cannot set buffering mode" port mode size))))
164
165;;;; Port-mapping (found in Gauche):
166
167(define (port-for-each fn thunk)
168  (let loop ()
169    (let ((x (thunk)))
170      (unless (eof-object? x)
171	(fn x)
172	(loop) ) ) ) )
173
174(define port-map
175  (lambda (fn thunk)
176    (let loop ((xs '()))
177      (let ((x (thunk)))
178	(if (eof-object? x)
179	    (##sys#fast-reverse xs)
180	    (loop (cons (fn x) xs)))))))
181
182(define (port-fold fn acc thunk)
183  (let loop ((acc acc))
184    (let ((x (thunk)))
185      (if (eof-object? x)
186          acc
187          (loop (fn x acc))) ) ) )
188
189(define-constant +buf-size+ 1024)
190
191(define copy-port
192  (let ((read-char read-char)
193        (write-char write-char))
194    (define (read-and-write src dest)
195      (##sys#check-port src 'copy-port)
196      (##sys#check-port dest 'copy-port)
197      (let ((buf (##sys#make-bytevector +buf-size+)))
198        (let loop ()
199          (let ((n (chicken.io#read-bytevector!/port +buf-size+ buf src 0)))
200            (unless (eq? n 0)
201              (chicken.io#write-bytevector buf dest 0 n)
202              (loop))))))
203    (define (read-and-delegate src dest writer)
204      (##sys#check-port src 'copy-port)
205      (let ((buf (##sys#make-bytevector +buf-size+)))
206        (let loop ((p 0))
207          (let* ((n (chicken.io#read-bytevector!/port
208                      (fx- +buf-size+ p)
209                      buf src p))
210                 (fc (##core#inline "C_utf_fragment_counts" buf 0 n))
211                 (full (fxshr fc 4))
212                 (part (fxand fc 7))
213                 (str (##sys#buffer->string buf 0 (fx- n part))))
214            (unless (eq? n 0)
215              (do ((i 0 (fx+ i 1)))
216                      ((fx>= i full))
217                (writer (string-ref str i) dest))
218              ;; overlaps, buf source will be at end of buffer
219              (##core#inline "C_copy_memory_with_offset"
220                buf buf
221                (fx- (fx- (##sys#size (##sys#slot str 0)) 1) part)
222                0 part)
223              (loop part))))))
224    (define (delegate src reader dest writer)
225      (let loop ()
226        (let ((x (reader src)))
227          (unless (eof-object? x)
228            (writer x dest)
229            (loop)))))
230    (define (delegate-and-write src reader dest)
231      (##sys#check-port dest 'copy-port)
232      (let ((buf (##sys#make-bytevector (fx+ 4 +buf-size+))))
233        (let loop ((n 0))
234          (when (fx>= n +buf-size+)
235            (chicken.io#write-bytevector buf dest 0 n)
236            (set! n 0))
237          (let ((c (reader src)))
238            (cond ((eof-object? c)
239                   (when (fx>= n 0)
240                     (chicken.io#write-bytevector buf dest 0 n)))
241                  (else
242                   (loop (##core#inline "C_utf_insert" buf n c))))))))
243    (lambda (src dest #!optional (read read-char) (write write-char))
244      ;; does not check port args intentionally
245      (cond ((eq? read read-char)
246                  (if (eq? write write-char)
247                      (read-and-write src dest)
248                  (read-and-delegate src dest write)))
249            ((eq? write write-char)
250             (delegate-and-write src read dest))
251            (else (delegate src read dest write))))))
252
253
254;;;; funky-ports
255
256(define (make-broadcast-port . ports)
257  (make-output-port
258   (lambda (s) (for-each (cut scheme#write-string s <>) ports))
259   void
260   (lambda () (for-each flush-output ports)) ) )
261
262(define (make-concatenated-port p1 . ports)
263  (let ((ports (cons p1 ports)))
264    ;;XXX should also forward other port-methods
265    (make-input-port
266     (lambda ()
267       (let loop ()
268	 (if (null? ports)
269	     #!eof
270	     (let ((c (read-char (car ports))))
271	       (cond ((eof-object? c)
272		      (set! ports (cdr ports))
273		      (loop) )
274		     (else c) ) ) ) ) )
275     (lambda ()
276       (and (not (null? ports))
277	    (char-ready? (car ports))))    ; must this depend on encoding of port?
278     void
279     peek-char:
280     (lambda ()
281       (let loop ()
282	 (if (null? ports)
283	     #!eof
284	     (let ((c (peek-char (car ports))))
285	       (cond ((eof-object? c)
286		      (set! ports (cdr ports))
287		      (loop) )
288		     (else c))))))
289     read-bytevector:
290     (lambda (dest start end)
291       (let loop ((n (fx- end start)) (c 0) (p start))
292	 (cond ((null? ports) c)
293	       ((fx<= n 0) c)
294	       (else
295		(let ((m (read-bytevector! dest (car ports) p (+ p n))))
296		  (when (fx< m n)
297		    (set! ports (cdr ports)) )
298		  (loop (fx- n m) (fx+ c m) (fx+ p m))))))))))
299
300
301;;; Redirect standard ports:
302
303(define (with-input-from-port port thunk)
304  (##sys#check-input-port port #t 'with-input-from-port)
305  (fluid-let ((##sys#standard-input port))
306    (thunk) ) )
307
308(define (with-output-to-port port thunk)
309  (##sys#check-output-port port #t 'with-output-to-port)
310  (fluid-let ((##sys#standard-output port))
311    (thunk) ) )
312
313(define (with-error-output-to-port port thunk)
314  (##sys#check-output-port port #t 'with-error-output-to-port)
315  (fluid-let ((##sys#standard-error port))
316    (thunk) ) )
317
318;;; Extended string-port operations:
319
320(define call-with-input-string
321  (lambda (str proc)
322    (let ((in (open-input-string str)))
323      (proc in) ) ) )
324
325(define call-with-output-string
326  (lambda (proc)
327    (let ((out (open-output-string)))
328      (proc out)
329      (get-output-string out) ) ) )
330
331(define with-input-from-string
332  (lambda (str thunk)
333    (fluid-let ([##sys#standard-input (open-input-string str)])
334      (thunk) ) ) )
335
336(define with-output-to-string
337  (lambda (thunk)
338    (fluid-let ((##sys#standard-output (open-output-string)))
339      (thunk)
340      (get-output-string ##sys#standard-output) ) ) )
341
342(define with-error-output-to-string
343  (lambda (thunk)
344    (fluid-let ((##sys#standard-error (open-output-string)))
345      (thunk)
346      (get-output-string ##sys#standard-error) ) ) )
347
348;;; Custom ports:
349;
350; - Port-slots:
351;
352;   10: last/peeked
353
354(define make-input-port
355  (lambda (read ready? close       ; "read-buffered" is deprecated
356                #!key peek-char read-bytevector read-line read-buffered)
357    (define (insert dest start c)
358      (let* ((bv (##sys#make-bytevector 4))
359             (m (##core#inline "C_utf_insert" bv 0 c)))
360        (##core#inline "C_copy_memory_with_offset" dest bv 0 start m)
361        m))
362    (let* ((class
363	    (vector
364	     (lambda (p)		; read-char
365	       (let ((last (##sys#slot p 10)))
366		 (cond (peek-char (read))
367		       (last
368			(##sys#setislot p 10 #f)
369			last)
370		       (else (read)) ) ) )
371	     (lambda (p)		; peek-char
372	       (let ((last (##sys#slot p 10)))
373		 (cond (peek-char (peek-char))
374		       (last last)
375		       (else
376			(let ((last (read)))
377			  (##sys#setslot p 10 last)
378			  last) ) ) ) )
379	     #f				; write-char
380	     #f				; write-bytevector
381	     (lambda (p d)		; close
382	       (close))
383	     #f				; flush-output
384	     (lambda (p)		; u8-ready?
385	       (ready?) )
386	     (if read-bytevector	; read-bytevector!
387                 (lambda (p n dest start)
388                  (let ((last (and (not peek-char) (##sys#slot p 10)))
389                        (m 0))
390                    (when last
391                      (set! m (insert dest start last))
392                      (##sys#setislot p 10 #f)
393                      (set! start (fx+ start m))
394                      (set! n (and n (fx- n m))))
395                    (if (and n (fx<= n m))
396                        m
397                        (fx+ m (read-bytevector dest start (and n (fx+ start n)))))))
398	         (lambda (p n dest start)
399	           (let loop ((n n) (c 0))
400                     (cond ((eq? n 0) c)
401                           ((and (not peek-char) (##sys#slot p 10)) =>
402                             (lambda (last)
403                               (let ((m (insert dest start last)))
404                                 (##sys#setislot p 10 #f)
405                                 (loop (and n (fx- n m)) (fx+ c m)))))
406                          (else
407                            (let ((x (read)))
408                              (if (eof-object? x) 
409                                  c
410                                  (let ((m (insert dest start x)))
411                                    (loop (and n (fx- n m)) (fx+ c m))))))))))
412	     read-line			; read-line
413	     read-buffered     ; read-buffered
414             (lambda (p) (ready?))  ; char-ready?
415             ))
416	   (data (vector #f))
417	   (port (##sys#make-port 1 class "(custom)" 'custom)))
418      (##sys#setslot port 10 #f)
419      (##sys#set-port-data! port data)
420      port) ) )
421
422(define make-output-port
423  (lambda (write close #!rest r #!key force-output)
424    ;XXX this is for ensuring old-style calls fail and can be removed at some stage
425    (when (and (pair? r) (not (##core#inline "C_i_keywordp" (car r))))
426      (error 'make-output-port "invalid invocation - use keyword parameters" r))
427    (let* ((class
428	    (vector
429	     #f				; read-char
430	     #f				; peek-char
431	     (lambda (p c)		; write-char
432	       (write (string c)) )
433	     (lambda (p bv from to)   	; write-bytevector
434               (let ((len (fx- to from)))
435                 (write (##sys#buffer->string bv from len))))
436	     (lambda (p d)		; close
437	       (close))
438	     (lambda (p)		; flush-output
439	       (when force-output (force-output)) )
440	     #f				; u8-ready?
441	     #f				; read-bytevector!
442             #f                         ; read-line
443             #f                        ; read-buffered
444             #f                        ; char-ready?
445             ))
446	   (data (vector #f))
447	   (port (##sys#make-port 2 class "(custom)" 'custom)))
448      (##sys#set-port-data! port data)
449      port) ) )
450
451(define make-binary-input-port
452  (lambda (read ready? close #!key peek-u8 read-bytevector)
453    (define read-bv
454      (if read-bytevector
455          (lambda (p n dest start)
456            (let* ((off (getlast p dest start))
457                   (start (##core#inline "C_fixnum_plus" start off))
458                   (n (##core#inline "C_fixnum_difference" n off)))
459              (##core#inline "C_fixnum_plus"
460               off 
461               (read-bytevector dest start (##core#inline "C_fixnum_plus" start n)))))
462          (lambda (p n dest start)
463            (let* ((off (getlast p dest start))
464                   (start (##core#inline "C_fixnum_plus" start off))
465                   (n (##core#inline "C_fixnum_difference" n off)))
466              (##core#inline "C_fixnum_plus"
467               off 
468               (let loop ((i 0))
469                 (if (##core#inline "C_fixnum_greater_or_equal_p" i n)
470                     i
471                     (let ((b (read)))
472                       (cond ((eof-object? b) i)
473                             (else
474                               (##core#inline "C_setsubbyte" 
475                                dest
476                                (##core#inline "C_fixnum_plus" i start)
477                                b)
478                               (loop (##core#inline "C_fixnum_plus" i 1))))))))))))
479    (define (getlast p dest i)
480      (let ((last (##sys#slot p 10)))
481        (cond (last 
482                (##core#inline "C_setsubbyte" dest i (char->integer last))
483                (##sys#setislot p 10 #f)
484                1)
485              (else 0))))
486    (define (tochar x) 
487      (if (eof-object? x)
488          x
489          (integer->char x)))
490    (let* ((class
491             (vector
492               (lambda (p)                ; read-char
493                 (let ((last (##sys#slot p 10)))
494                   (cond (last
495                           (##sys#setislot p 10 #f)
496                           last)
497                         (else (tochar (read)) ) ) ))
498               (lambda (p)                ; peek-char
499                 (let ((last (##sys#slot p 10)))
500                   (cond (peek-u8 (tochar (peek-u8)))
501                         (last last)
502                         (else
503                           (let ((last (tochar (read))))
504                             (##sys#setislot p 10 last)
505                             last) ) ) ) )
506               #f                         ; write-char
507               #f                         ; write-bytevector
508               (lambda (p d)              ; close
509                 (close))
510               #f                         ; flush-output
511               (lambda (p)                ; u8-ready?
512                 (ready?) )
513               read-bv        ; read-bytevector!
514               #f                  ; read-line
515               #f                  ; read-buffered
516               (lambda (p) (ready?))      ; char-ready?
517               ))
518           (data (vector #f))
519           (port (##sys#make-port 1 class "(custom binary)" 'custom)))
520      (##sys#setslot port 10 #f)
521      (##sys#setslot port 14 'binary)
522      (##sys#setslot port 15 'binary)
523      (##sys#set-port-data! port data)
524      port) ) )
525      
526(define make-binary-output-port
527  (lambda (write close #!key force-output write-bytevector)
528    (define write-bv 
529      (or write-bytevector
530          (lambda (bv start end) 
531            (##sys#check-bytevector bv 'make-binary-output-port)
532            (let loop ((i start)
533                       (end (or end (##sys#size bv))))
534               (unless (##core#inline "C_fixnum_greater_or_equal_p" i end)
535                 (write (##core#inline "C_subbyte" bv i))
536                 (loop (##core#inline "C_fixnum_plus" i 1) end))))))
537    (let* ((class
538             (vector
539               #f                      ; read-char
540               #f                      ; peek-char
541               (lambda (p c)       ; write-char
542                 (let* ((len (##core#inline "C_utf_bytes" c))
543                        (buf (##sys#make-bytevector len))
544                        (n (##core#inline "C_utf_insert" buf 0 c)))
545                   (write-bv buf 0 len)))
546               (lambda (p bv from to)           ; write-bytevector
547                 (write-bv bv from to))
548               (lambda (p d)       ; close
549                 (close))
550               (lambda (p)           ; flush-output
551                 (when force-output (force-output)) )
552               #f                      ; u8-ready?
553               #f                      ; read-bytevector!
554               #f                         ; read-line
555               #f                         ; read-buffered
556               #f                         ; char-ready?
557               ))
558           (data (vector #f))
559           (port (##sys#make-port 2 class "(custom binary)" 'custom)))
560      (##sys#set-port-data! port data)
561      (##sys#setslot port 15 'binary)
562      (##sys#setslot port 14 'binary)
563      port) ) )
564      
565(define (make-bidirectional-port i o)
566  (let* ((class (vector
567		 (lambda (_)             ; read-char
568		   (read-char i))
569		 (lambda (_)             ; peek-char
570		   (peek-char i))
571		 (lambda (_ c)           ; write-char
572		   (write-char c o))
573                 (lambda (_ bv from to)  ; write-bytevector
574                   (chicken.io#write-bytevector bv o from to))
575		 (lambda (_ d)           ; close
576		   (case d
577		     ((1) (close-input-port i))
578		     ((2) (close-output-port o))))
579		 (lambda (_)             ; flush-output
580		   (flush-output o))
581		 (lambda (_)             ; u8-ready?
582		   (u8-ready? i))
583		 (lambda (_ n d s)       ; read-bytevector!
584		   (chicken.io#read-bytevector! d i s (fx+ s n)))
585		 (lambda (_ l)           ; read-line
586		   (read-line i l))
587		 (lambda (_)              ; read-buffered
588		   (read-buffered i))     ; DEPRECATED
589                 (lambda (_)            ; char-ready?
590                   (char-ready? i))))
591	 (port (##sys#make-port 3 class "(bidirectional)" 'bidirectional)))
592    (##sys#set-port-data! port (vector #f))
593    port))
594
595;; Duplication from posix-common.scm
596(define posix-error
597  (let ((strerror (foreign-lambda c-string "strerror" int))
598	(string-append string-append))
599    (lambda (type loc msg . args)
600      (let ((rn (##sys#update-errno)))
601        (apply ##sys#signal-hook/errno
602               type rn loc (string-append msg " - " (strerror rn)) args)))))
603
604;; Terminal ports
605(define (terminal-port? port)
606  (##sys#check-open-port port 'terminal-port?)
607  (let ((fp (##sys#peek-unsigned-integer port 0)))
608    (and (not (eq? 0 fp)) (##core#inline "C_tty_portp" port))))
609
610(define (check-terminal! caller port)
611  (##sys#check-open-port port caller)
612  (unless (and (eq? 'stream (##sys#slot port 7))
613	       (##core#inline "C_tty_portp" port))
614    (##sys#error caller "port is not connected to a terminal" port)))
615
616(define terminal-name
617  (let ((ttyname (foreign-lambda c-string "ttyname" int)))
618    (lambda (port)
619      (check-terminal! 'terminal-name port)
620      (or (ttyname (##core#inline "C_port_fileno" port))
621	  (posix-error #:error 'terminal-name
622		       "cannot determine terminal name" port)))))
623
624(define terminal-size
625  (let ((ttysize (foreign-lambda int "get_tty_size" int
626				 (nonnull-c-pointer int)
627				 (nonnull-c-pointer int))))
628    (lambda (port)
629      (check-terminal! 'terminal-size port)
630      (let-location ((columns int)
631		     (rows int))
632	(if (fx= 0 (ttysize (##core#inline "C_port_fileno" port)
633			    (location rows)
634			    (location columns)))
635	    (values rows columns)
636	    (posix-error #:error 'terminal-size
637			 "cannot determine terminal size" port))))))
638
639)