On this page:
make-input-port
make-output-port
12.1.9 Custom Ports

The make-input-port and make-output-port procedures create custom ports with arbitrary control procedures (much like implementing a device driver). Custom ports are mainly useful to obtain fine control over the action of committing bytes as read or written.

(make-input-port name    
  read-in    
  peek    
  close    
  [get-progress-evt    
  commit    
  get-location    
  count-lines!    
  init-position    
  buffer-mode])  input-port?
  name : any/c
  read-in : 
(bytes?
 . -> . (or/c exact-nonnegative-integer?
              eof-object?
              procedure?
              evt?))
  peek : 
(bytes? exact-nonnegative-integer? (or/c evt? #f)
        . -> . (or/c exact-nonnegative-integer?
                     eof-object?
                     procedure?
                     evt?
                     #f))
  close : (-> any)
  get-progress-evt : (or/c (-> evt?) #f) = #f
  commit : 
(or/c (exact-positive-integer? evt? evt? . -> . any)
      #f)
   = #f
  get-location : 
(or/c
 (()
  . ->* .
  ((or/c exact-positive-integer? #f)
   (or/c exact-nonnegative-integer? #f)
   (or/c exact-positive-integer? #f)))
 #f)
 = #f
  count-lines! : (-> any) = void
  init-position : exact-positive-integer? = 1
  buffer-mode : 
(or/c (case-> ((or/c 'block 'none) . -> . any)
              (-> (or/c 'block 'none #f)))
      #f)
   = #f
Creates an input port, which is immediately open for reading. If close procedure has no side effects, then the port need not be explicitly closed. See also make-input-port/peek-to-read.

The arguments implement the port as follows:

“Special” results: When read-in or peek (or an event produced by one of these) returns a procedure, the procedure is used to obtain a non-byte result. (This non-byte result is not intended to return a character or eof; in particular, read-char raises an exception if it encounters a special-result procedure, even if the procedure produces a byte.) A special-result procedure must accept four arguments, and it can optionally accept zero arguments:

The special-value procedure can return an arbitrary value, and it will be called zero or one times (not necessarily before further reads or peeks from the port). See Reader-Extension Procedures for more details on the procedure’s result.

If read-in or peek returns a special procedure when called by any reading procedure other than read, read-syntax, read-honu, read-honu-syntax, read-char-or-special, peek-char-or-special, read-byte-or-special, or peek-byte-or-special, then the exn:fail:contract exception is raised.

Examples:

; A port with no input...
; Easy: (open-input-bytes #"")
; Hard:
> (define /dev/null-in
    (make-input-port 'null
                     (lambda (s) eof)
                     (lambda (skip s progress-evt) eof)
                     void
                     (lambda () never-evt)
                     (lambda (k progress-evt done-evt)
                       (error "no successful peeks!"))))
> (read-char /dev/null-in)

#<eof>

> (peek-char /dev/null-in)

#<eof>

> (read-byte-or-special /dev/null-in)

#<eof>

> (peek-byte-or-special /dev/null-in 100)

#<eof>

; A port that produces a stream of 1s:
> (define infinite-ones
    (make-input-port
     'ones
     (lambda (s)
       (bytes-set! s 0 (char->integer #\1)) 1)
     #f
     void))
> (read-string 5 infinite-ones)

"11111"

; But we can't peek ahead arbitrarily far, because the
; automatic peek must record the skipped bytes, so
; we'd run out of memory.
; An infinite stream of 1s with a specific peek procedure:
> (define infinite-ones
    (let ([one! (lambda (s)
                  (bytes-set! s 0 (char->integer #\1)) 1)])
      (make-input-port
       'ones
       one!
       (lambda (s skip progress-evt) (one! s))
       void)))
> (read-string 5 infinite-ones)

"11111"

; Now we can peek ahead arbitrarily far:
> (peek-string 5 (expt 2 5000) infinite-ones)

"11111"

; The port doesn't supply procedures to implement progress events:
> (port-provides-progress-evts? infinite-ones)

#f

> (port-progress-evt infinite-ones)

port-progress-evt: port does not provide progress evts:

#<input-port:ones>

; Non-byte port results:
> (define infinite-voids
    (make-input-port
     'voids
     (lambda (s) (lambda args 'void))
     (lambda (skip s evt) (lambda args 'void))
     void))
> (read-char infinite-voids)

read-char: non-character in an unsupported context, from

port: #<input-port:voids>

> (read-char-or-special infinite-voids)

'void

; This port produces 0, 1, 2, 0, 1, 2, etc., but it is not
; thread-safe, because multiple threads might read and change n.
> (define mod3-cycle/one-thread
    (let* ([n 2]
           [mod! (lambda (s delta)
                   (bytes-set! s 0 (+ 48 (modulo (+ n delta) 3)))
                   1)])
      (make-input-port
       'mod3-cycle/not-thread-safe
       (lambda (s)
         (set! n (modulo (add1 n) 3))
         (mod! s 0))
       (lambda (s skip evt)
         (mod! s skip))
       void)))
> (read-string 5 mod3-cycle/one-thread)

"01201"

> (peek-string 5 (expt 2 5000) mod3-cycle/one-thread)

"20120"

; Same thing, but thread-safe and kill-safe, and with progress
; events. Only the server thread touches the stateful part
; directly. (See the output port examples for a simpler thread-safe
; example, but this one is more general.)
> (define (make-mod3-cycle)
    (define read-req-ch (make-channel))
    (define peek-req-ch (make-channel))
    (define progress-req-ch (make-channel))
    (define commit-req-ch (make-channel))
    (define close-req-ch (make-channel))
    (define closed? #f)
    (define n 0)
    (define progress-sema #f)
    (define (mod! s delta)
      (bytes-set! s 0 (+ 48 (modulo (+ n delta) 3)))
      1)
    ; -
    ; The server has a list of outstanding commit requests,
    ;  and it also must service each port operation (read,
    ;  progress-evt, etc.)
    (define (serve commit-reqs response-evts)
      (apply
       sync
       (handle-evt read-req-ch
                   (handle-read commit-reqs response-evts))
       (handle-evt progress-req-ch
                   (handle-progress commit-reqs response-evts))
       (handle-evt commit-req-ch
                   (add-commit commit-reqs response-evts))
       (handle-evt close-req-ch
                   (handle-close commit-reqs response-evts))
       (append
        (map (make-handle-response commit-reqs response-evts)
             response-evts)
        (map (make-handle-commit commit-reqs response-evts)
             commit-reqs))))
    ; Read/peek request: fill in the string and commit
    (define ((handle-read commit-reqs response-evts) r)
      (let ([s (car r)]
            [skip (cadr r)]
            [ch (caddr r)]
            [nack (cadddr r)]
            [evt (car (cddddr r))]
            [peek? (cdr (cddddr r))])
        (let ([fail? (and evt
                          (sync/timeout 0 evt))])
          (unless (or closed? fail?)
            (mod! s skip)
            (unless peek?
              (commit! 1)))
          ; Add an event to respond:
          (serve commit-reqs
                 (cons (choice-evt
                        nack
                        (channel-put-evt ch (if closed?
                                                0
                                                (if fail? #f 1))))
                       response-evts)))))
    ; Progress request: send a peek evt for the current
    ;  progress-sema
    (define ((handle-progress commit-reqs response-evts) r)
      (let ([ch (car r)]
            [nack (cdr r)])
        (unless progress-sema
          (set! progress-sema (make-semaphore (if closed? 1 0))))
        ; Add an event to respond:
        (serve commit-reqs
               (cons (choice-evt
                      nack
                      (channel-put-evt
                       ch
                       (semaphore-peek-evt progress-sema)))
                     response-evts))))
    ; Commit request: add the request to the list
    (define ((add-commit commit-reqs response-evts) r)
      (serve (cons r commit-reqs) response-evts))
    ; Commit handling: watch out for progress, in which case
    ;  the response is a commit failure; otherwise, try
    ;  to sync for a commit. In either event, remove the
    ;  request from the list
    (define ((make-handle-commit commit-reqs response-evts) r)
      (let ([k (car r)]
            [progress-evt (cadr r)]
            [done-evt (caddr r)]
            [ch (cadddr r)]
            [nack (cddddr r)])
        ; Note: we don't check that k is <= the sum of
        ;  previous peeks, because the entire stream is actually
        ;  known, but we could send an exception in that case.
        (choice-evt
         (handle-evt progress-evt
                     (lambda (x)
                       (sync nack (channel-put-evt ch #f))
                       (serve (remq r commit-reqs) response-evts)))
         ; Only create an event to satisfy done-evt if progress-evt
         ;  isn't already ready.
         ; Afterward, if progress-evt becomes ready, then this
         ;  event-making function will be called again, because
         ;  the server controls all posts to progress-evt.
         (if (sync/timeout 0 progress-evt)
             never-evt
             (handle-evt done-evt
                         (lambda (v)
                           (commit! k)
                           (sync nack (channel-put-evt ch #t))
                           (serve (remq r commit-reqs)
                                  response-evts)))))))
    ; Response handling: as soon as the respondee listens,
    ;  remove the response
    (define ((make-handle-response commit-reqs response-evts) evt)
      (handle-evt evt
                  (lambda (x)
                    (serve commit-reqs
                           (remq evt response-evts)))))
    ; Close handling: post the progress sema, if any, and set
    ;   the closed? flag
    (define ((handle-close commit-reqs response-evts) r)
      (let ([ch (car r)]
            [nack (cdr r)])
        (set! closed? #t)
        (when progress-sema
          (semaphore-post progress-sema))
        (serve commit-reqs
               (cons (choice-evt nack
                                 (channel-put-evt ch (void)))
                     response-evts))))
    ; Helper for reads and post-peek commits:
    (define (commit! k)
      (when progress-sema
        (semaphore-post progress-sema)
        (set! progress-sema #f))
      (set! n (+ n k)))
    ; Start the server thread:
    (define server-thread (thread (lambda () (serve null null))))
    ; -
    ; Client-side helpers:
    (define (req-evt f)
      (nack-guard-evt
       (lambda (nack)
         ; Be sure that the server thread is running:
         (thread-resume server-thread (current-thread))
         ; Create a channel to hold the reply:
         (let ([ch (make-channel)])
           (f ch nack)
           ch))))
    (define (read-or-peek-evt s skip evt peek?)
      (req-evt (lambda (ch nack)
                 (channel-put read-req-ch
                              (list* s skip ch nack evt peek?)))))
    ; Make the port:
    (make-input-port 'mod3-cycle
                     ; Each handler for the port just sends
                     ;  a request to the server
                     (lambda (s) (read-or-peek-evt s 0 #f #f))
                     (lambda (s skip evt)
                       (read-or-peek-evt s skip evt #t))
                     (lambda () ; close
                       (sync (req-evt
                              (lambda (ch nack)
                                (channel-put progress-req-ch
                                             (list* ch nack))))))
                     (lambda () ; progress-evt
                       (sync (req-evt
                              (lambda (ch nack)
                                (channel-put progress-req-ch
                                             (list* ch nack))))))
                     (lambda (k progress-evt done-evt)  ; commit
                       (sync (req-evt
                              (lambda (ch nack)
                                (channel-put
                                 commit-req-ch
                                 (list* k progress-evt done-evt ch
                                        nack))))))))
> (define mod3-cycle (make-mod3-cycle))
> (let ([result1 #f]
        [result2 #f])
    (let ([t1 (thread
               (lambda ()
                 (set! result1 (read-string 5 mod3-cycle))))]
          [t2 (thread
               (lambda ()
                 (set! result2 (read-string 5 mod3-cycle))))])
      (thread-wait t1)
      (thread-wait t2)
      (string-append result1 "," result2)))

"10200,02112"

> (define s (make-bytes 1))
> (define progress-evt (port-progress-evt mod3-cycle))
> (peek-bytes-avail! s 0 progress-evt mod3-cycle)

1

> s

#"1"

> (port-commit-peeked 1 progress-evt (make-semaphore 1)
                      mod3-cycle)

#t

> (sync/timeout 0 progress-evt)

#<progress-evt>

> (peek-bytes-avail! s 0 progress-evt mod3-cycle)

0

> (port-commit-peeked 1 progress-evt (make-semaphore 1)
                      mod3-cycle)

#f

> (close-input-port mod3-cycle)

(make-output-port name    
  evt    
  write-out    
  close    
  [write-out-special    
  get-write-evt    
  get-write-special-evt    
  get-location    
  count-lines!    
  init-position    
  buffer-mode])  output-port?
  name : any/c
  evt : evt?
  write-out : 
(bytes? exact-nonnegative-integer?
        exact-nonnegative-integer?
        boolean?
        boolean?
        . -> .
        (or/c exact-nonnegative-integer?
              #f
              evt?))
  close : (-> any)
  write-out-special : 
(or/c (any/c boolean? boolean?
             . -> .
             (or/c any/c
                   #f
                   evt?))
      #f)
 = #f
  get-write-evt : 
(or/c
 (bytes? exact-nonnegative-integer?
         exact-nonnegative-integer?
         . -> .
         evt?)
 #f)
 = #f
  get-write-special-evt : 
(or/c
 (any/c . -> . evt?)
 #f)
 = #f
  get-location : 
(or/c
 (()
  . ->* .
  ((or/c exact-positive-integer? #f)
   (or/c exact-nonnegative-integer? #f)
   (or/c exact-positive-integer? #f)))
 #f)
 = #f
  count-lines! : (-> any) = void
  init-position : exact-positive-integer? = 1
  buffer-mode : 
(or/c (case->
       ((or/c 'block 'line 'none) . -> . any)
       (-> (or/c 'block 'line 'none #f)))
      #f)
   = #f
Creates an output port, which is immediately open for writing. If close procedure has no side effects, then the port need not be explicitly closed. The port can buffer data within its write-out and write-out-special procedures.

Examples:

; A port that writes anything to nowhere:
> (define /dev/null-out
    (make-output-port
     'null
     always-evt
     (lambda (s start end non-block? breakable?) (- end start))
     void
     (lambda (special non-block? breakable?) #t)
     (lambda (s start end) (wrap-evt
                            always-evt
                            (lambda (x)
                              (- end start))))
     (lambda (special) always-evt)))
> (display "hello" /dev/null-out)
> (write-bytes-avail #"hello" /dev/null-out)

5

> (write-special 'hello /dev/null-out)

#t

> (sync (write-bytes-avail-evt #"hello" /dev/null-out))

5

; A port that accumulates bytes as characters in a list,
;  but not in a thread-safe way:
> (define accum-list null)
> (define accumulator/not-thread-safe
    (make-output-port
     'accum/not-thread-safe
     always-evt
     (lambda (s start end non-block? breakable?)
       (set! accum-list
             (append accum-list
                     (map integer->char
                          (bytes->list (subbytes s start end)))))
       (- end start))
     void))
> (display "hello" accumulator/not-thread-safe)
> accum-list

'(#\h #\e #\l #\l #\o)

; Same as before, but with simple thread-safety:
> (define accum-list null)
> (define accumulator
    (let* ([lock (make-semaphore 1)]
           [lock-peek-evt (semaphore-peek-evt lock)])
      (make-output-port
       'accum
       lock-peek-evt
       (lambda (s start end non-block? breakable?)
         (if (semaphore-try-wait? lock)
             (begin
               (set! accum-list
                     (append accum-list
                             (map integer->char
                                  (bytes->list
                                   (subbytes s start end)))))
               (semaphore-post lock)
               (- end start))
             ; Cheap strategy: block until the list is unlocked,
             ;   then return 0, so we get called again
             (wrap-evt
              lock-peek
              (lambda (x) 0))))
       void)))
> (display "hello" accumulator)
> accum-list

'(#\h #\e #\l #\l #\o)

; A port that transforms data before sending it on
;  to another port. Atomic writes exploit the
;  underlying port's ability for atomic writes.
> (define (make-latin-1-capitalize port)
    (define (byte-upcase s start end)
      (list->bytes
       (map (lambda (b) (char->integer
                         (char-upcase
                          (integer->char b))))
            (bytes->list (subbytes s start end)))))
    (make-output-port
     'byte-upcase
     ; This port is ready when the original is ready:
     port
     ; Writing procedure:
     (lambda (s start end non-block? breakable?)
       (let ([s (byte-upcase s start end)])
         (if non-block?
             (write-bytes-avail* s port)
             (begin
               (display s port)
               (bytes-length s)))))
     ; Close procedure close original port:
     (lambda () (close-output-port port))
     #f
     ; Write event:
     (and (port-writes-atomic? port)
          (lambda (s start end)
            (write-bytes-avail-evt
             (byte-upcase s start end)
             port)))))
> (define orig-port (open-output-string))
> (define cap-port (make-latin-1-capitalize orig-port))
> (display "Hello" cap-port)
> (get-output-string orig-port)

"HELLO"

> (sync (write-bytes-avail-evt #"Bye" cap-port))

3

> (get-output-string orig-port)

"HELLOBYE"