(module
 bokbok-packet
 (make-core-object
  core-object?
  core-object-tag
  core-object-value

  max-receive-depth
  max-receive-length

  read-binary
  write-binary

  split-packet
  join-packet)

 (import chicken scheme)
 (use extras)
 (use ports)
 (use numbers)

   (define-record-type core-object
    (make-core-object tag value)
    core-object?
    (tag core-object-tag)
    (value core-object-value))

   ;; Literals in code can't be this big, so we have to cheat.
  (define two63 (expt 2 63))
  (define two64 (expt 2 64))

  (define (read-s8 port)
    (let ((v (read-byte port)))
      (if (eof-object? v)
          #!eof
          (if (< v 128)
              v
              (- v 256)))))

  (define (read-u16 port)
    (let* ((b1 (read-byte port))
           (b2 (read-byte port)))
      (if (or (eof-object? b1) (eof-object? b2))
          #!eof
          (+ (* b1 256) b2))))

  (define (write-u16 i port)
    (write-byte (quotient i 256) port)
    (write-byte (modulo i 256) port))

  (define (read-s16 port)
    (let ((v (read-u16 port)))
      (if (eof-object? v)
          #!eof
          (if (< v 32768)
              v
              (- v 65536)))))

  (define (write-s16 i port)
    (if (negative? i)
        (write-u16 (+ 65536 i) port)
        (write-u16 i port)))

  (define (read-u32 port)
    (let ((w1 (read-u16 port))
          (w2 (read-u16 port)))
      (if (or (eof-object? w1) (eof-object? w2))
          #!eof
          (+ (* w1 65536) w2))))

  (define (write-u32 i port)
    (write-byte (quotient i 16777216) port)
    (write-byte (quotient (modulo i 16777216) 65536) port)
    (write-byte (quotient (modulo i 65536) 256) port)
    (write-byte (modulo i 256) port))

  (define (read-s32 port)
    (let ((v (read-u32 port)))
      (if (eof-object? v)
          #!eof
          (if (< v 2147483648)
              v
              (- v 4294967296)))))

  (define (write-s32 i port)
    (if (negative? i)
        (write-u32 (+ 4294967296 i) port)
        (write-u32 i port)))

  (define (read-u64 port)
    (let ((w1 (read-u32 port))
          (w2 (read-u32 port)))
      (if (or (eof-object? w1) (eof-object? w2))
          #!eof
          (+ (* w1 4294967296) w2))))

  (define (write-u64 i port)
    (write-u32 (quotient i 4294967296) port)
    (write-u32 (modulo i 4294967296) port))

  (define (read-s64 port)
    (let ((v (read-u64 port)))
      (if (eof-object? v)
          #!eof
          (if (< v two63)
              v
              (- v two64)))))

  (define (write-s64 i port)
    (if (negative? i)
        (write-u64 (+ two64 i) port)
        (write-u64 i port)))

  (define (read-length port)
    (let ((b (read-byte port)))
      (cond
       ((eof-object? b)
        #!eof)
       ((= b #x80)
        'variable)
       ((< b #x80)
        b)
       ((eq? b #x82)
        (read-u16 port))
       ((eq? b #x84)
        (read-u32 port))
       ((eq? b #x88)
        (read-u64 port))
       (else
        (error "Unknown length prefix" b)))))

  (define (write-length l port)
    (cond
     ((< l #x80)
      (write-byte l port))
     ((< l #x8000)
      (write-byte #x82)
      (write-u16 l port))
     ((< l #x80000000)
      (write-byte #x84)
      (write-u32 l port))
     ((< l two63)
      (write-byte #x88)
      (write-u64 l port))
     (else
      (error "Size too big" l))))

   (define (write-binary obj port)
    (cond
     ((list? obj)
      (write-byte #xe0 port)
      (write-byte #x80 port)
      (for-each
       (lambda (o)
         (write-binary o port))
       obj)
      (write-byte #x00 port)
      (write-byte #x00 port))
     ((symbol? obj)
      (let ((s (symbol->string obj)))
        (write-byte #xdd port)
        (write-length (string-length s) port)
        (write-string s #f port)))
     ((string? obj)
      (write-byte #x0c port)
      (write-length (string-length obj) port)
      (write-string obj #f port))
     ((boolean? obj)
      (write-byte #x01 port)
      (write-byte #x01 port)
      (write-byte (if obj #xff #x00) port))
     ((vector? obj)
      (write-byte #x30 port)
      (write-byte #x80 port)
      (let ((final (vector-length obj)))
        (let loop
            ((idx 0))
          (if (>= idx final)
              (begin
                (write-byte #x00 port)
                (write-byte #x00 port))
              (begin
                (write-binary (vector-ref obj idx) port)
                (loop (+ idx 1)))))))
     ((and (integer? obj) (exact? obj))
      (write-byte #x02 port)
      (cond
       ((zero? obj)
        (write-byte #x00 port))
       ((<= -128 obj 127)
        (write-byte #x01 port)
        (write-byte obj port))
       ((<= -32768 obj 32767)
        (write-byte #x02 port)
        (write-s16 obj port))
       ((<= -2147483648 obj 2147483647)
        (write-byte #x04 port)
        (write-s32 obj port))
       ((<= (- two63) obj (- two63 1))
        (write-byte #x08 port)
        (write-s64 obj port))
       (else
        ;; Chop into 64-bit chunks
        (let loop
            ((parts '())
             (n obj))
          (if (<= (- two63) n (- two63 1))
              (begin
                (write-length (* (+ 1 (length parts)) 8) port)
                (if (negative? obj)
                    (if (zero? (car parts))
                        (write-s64 -1 port)
                        (write-s64 (- n 1) port))
                    (write-s64 n port))
                (for-each
                 (lambda (p)
                   (write-u64 p port))
                 parts))
              (loop
               (cons (modulo n two64) parts)
               (quotient n two64)))))))
     ((number? obj)
      (write-byte #xfe port)
      (let ((s (number->string obj)))
        (write-length (string-length s) port)
        (write-string s #f port)))
     ((core-object? obj)
      (if (number? (core-object-tag obj))
          (begin
            (write-byte (core-object-tag obj) port)
            (write-byte #x80 port))
          (begin
            (let ((t (symbol->string (core-object-tag obj))))
              (write-byte #xFF port)
              (write-byte #x80 port)
              (write-byte #xdd port)
              (write-length (string-length t) port)
              (write-string t #f port))))
      (write-binary (core-object-value obj) port)
      (write-byte #x00 port)
      (write-byte #x00 port))
     (else
      (error "Unsupported kind of thing to write" obj))))

   (define (join-packet ps)
     (with-output-to-string
       (lambda ()
         (write-binary ps (current-output-port)))))

 (define max-receive-depth (make-parameter +inf.0))
 (define max-receive-length (make-parameter +inf.0))

 (define (read-binary* port level)
   (when (>= level (max-receive-depth))
     (error "Maximum receive depth exceeded"))
   (let* ((t (read-byte port))
          (l (read-length port)))
     (assert (or (eq? l 'variable) (<= l (max-receive-length))))
     (if (or (eof-object? t) (eof-object? l))
         #!eof
         (case t
           ((#xe0) ;; List
            (assert (eq? l 'variable))
            (let loop
                ((result '())
                 (length 0))
              (when (>= length (max-receive-length))
                (error "Maximum receive length exceeded in list"))
              (let ((v (read-binary* port (+ level 1))))
                (if (eof-object? v)
                    (reverse result)
                    (loop (cons v result)
                          (+ length 1))))))
           ((#xdd) ;; Symbol
            (string->symbol (read-string l port)))
           ((#x0c) ;; String
            (read-string l port))
           ((#x01) ;; Boolean
            (let ((v (read-byte port)))
              (case v
                ((#x00) #f)
                ((#xff) #t)
                (else (error "Invalid boolean value" v)))))
           ((#x30) ;; Vector
            (assert (eq? l 'variable))
            (let loop
                ((result '())
                 (length 0))
              (when (>= length (max-receive-length))
                (error "Maximum receive length exceeded in vector"))
              (let ((v (read-binary* port (+ level 1))))
                (if (eof-object? v)
                    (list->vector (reverse result))
                    (loop (cons v result)
                          (+ length 1))))))
           ((#x02) ;; Integer
            (case l
              ((#x00) 0)
              ((#x01) (read-s8 port))
              ((#x02) (read-s16 port))
              ((#x04) (read-s32 port))
              ((#x08) (read-s64 port))
              (else
               (assert (zero? (modulo l 8)))
               (let loop
                   ((result (read-s64 port))
                    (parts-left (- (/ l 8) 1)))
                 (if (zero? parts-left)
                     result
                     (let ((v (read-u64 port)))
                       (loop
                        (+ (* two64 result) v)
                        (- parts-left 1))))))))
           ((#xfe) ;; Arbitrary Scheme number
            (let ((s (read-string l port)))
              (string->number s)))
           ((#xff) ;; Symbol-tagged core object
            (assert (eq? l 'variable))
            (assert (= (read-byte port) #xdd))
            (let ((tl (read-length port)))
              (assert (<= tl (max-receive-length)))
              (let* ((tag (string->symbol (read-string tl port)))
                     (inner-value (read-binary* port (+ level 1))))
                (assert (= (read-byte port) #x00))
                (assert (= (read-byte port) #x00))
                (make-core-object tag inner-value))))
           ((#x00) ;; EOC
            (assert (= l 0))
            #!eof)
           (else ;; Number-tagged core object
            (assert (eq? l 'variable))
            (let ((inner-value (read-binary* port (+ level 1))))
              (assert (= (read-byte port) #x00))
              (assert (= (read-byte port) #x00))
             (make-core-object t inner-value)))))))

 (define (read-binary port)
   (read-binary* port 0))

 (define (split-packet ps)
   (with-input-from-string ps
       (lambda ()
         (read-binary (current-input-port)))))

 )