プログラミングErlang §12.2の外部プログラムをCではなくSchemeで書いてみるテスト

example1.scm

(define (twice x) (* 2 x))
(define (sum x y) (+ x y))

(use gauche.uvector)

(define-macro (ferr fmt . args)
;  `(format (current-error-port) ,fmt ,@args))
  #t)

(define (read-exact u8buf len)
  (ferr "read-exact: ~a, ~d\r\n" u8buf len)
  (let loop ((got 0))
    (ferr " (loop got:~d)\n" got)
    (let1 i (read-block! u8buf (current-input-port) got len #f)
      (if (eof-object? i) i
          (let1 got+i (+ got i)
            (if (< got+i len)
                (loop got+i)
                len))))))

(define (write-exact u8buf len)
  (ferr "write-exact: ~a, ~d\r\n" u8buf len)
;  (let loop ((wrote 0))
;   (ferr " (loop wrote:~d)\n" wrote)
    (write-block u8buf (current-output-port) 0 len #f)
    (flush)
    len)
    #;(let1 i (write-block u8buf (current-output-port) wrote len #f)
      (if (eof-object? i) i
          (let1 wrote+i (+ wrote i)
            (if (< wrote+i len)
                (loop wrote+i)
                len))))

(define (read-cmd u8buf)
  (ferr "read-cmd:\r\n")
  (let1 i (read-exact u8buf 2)
    (cond [(eof-object? i) #f]
          [(= 2 i)
           (let1 len (logior (ash (u8vector-ref u8buf 0) 8)
                             (u8vector-ref u8buf 1))
             (read-exact u8buf len))]
          [else #f])))

(define (write-cmd u8buf len)
  (ferr "write-cmd: ~a, ~d\r\n" u8buf len)
  (let1 wbuf (u8vector (logand (ash len -8) #xff)
                       (logand len #xff))
    (write-exact wbuf 2)
    (write-exact u8buf len)))

(define (main args)
  (let ([*currrent-buffering-mode* (port-buffering (current-input-port))]
        [buf (make-u8vector 5 0)])
    (set! (port-buffering (current-input-port)) :none)

    (while (read-cmd buf)
      (ferr "buf: ~a\n" buf)
      (let* ([fn (u8vector-ref buf 0)]
             [result (case fn
                       [(1)
                        (let1 arg (u8vector-ref buf 1)
                          (ferr "calling (twice ~d)\n" arg)
                          (twice arg))]
                       [(2)
                        (let ((arg1 (u8vector-ref buf 1))
                              (arg2 (u8vector-ref buf 2)))
                          (ferr "calling (sum ~d ~d)\n" arg1 arg2)
                          (sum arg1 arg2))]
                       [else #f])
                     ])
        (when result
;         (u8vector-set! buf 0 result)
;         (write-cmd buf 1))
          (let1 vec (u8vector (logand result #xff))
            (write-cmd vec 1)))

        (u8vector-fill! buf 0)
        (ferr "---\n")
        ))

    (set! (port-buffering (current-input-port)) *current-buffering-mode*)
    0))