;;; x-protocol.scm

;; Copyright (C) 2007, 2008, 2009, 2010, 2011 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Code:

(define-module (ttn-do zzz x-protocol)
  #:export (-connect
            -simple-io-manager
            -synchronous-request-proc
            -x
            -internal-data
            -wire<-event
            -event-type
            -event-synthetic?
            -event-data
            -disconnect)
  #:use-module ((ice-9 q) #:select ((make-q . q-make)
                                    q-empty?
                                    q-push!
                                    enq!
                                    deq!))
  #:use-module ((srfi srfi-1) #:select (remove
                                        lset-difference
                                        any
                                        car+cdr))
  #:use-module ((srfi srfi-11) #:select (let-values))
  #:use-module ((srfi srfi-13) #:select (string-take))
  #:use-module ((ttn-do zzz personally) #:select (accumulator
                                                  whatever
                                                  FE HFE fs fso fse make-fso))
  #:use-module ((ttn-do zz sys linux-gnu) #:select (iovec
                                                    writev
                                                    readv)))

(define WIDTH (make-hash-table 43))
(define SIGNED (list))
(define ENUMS (make-hash-table 19))
(define STRUCTS (make-hash-table 43))
(define ERRORS (make-hash-table 3))
(define EVENTS (make-hash-table 11))
(define REQUESTS (make-hash-table 31))
(define MASKS (make-hash-table 1))

;;;---------------------------------------------------------------------------
;;; fixed width trees

(define ra1d vector)                    ; array, 1-dimensional
(define ra1d-ref vector-ref)

(define fwt? vector?)

(define (fwt<- alloc resolve bufs)
  (ra1d alloc resolve (iovec bufs #:oneshot #f)))

(define (make-fwt spew? specs)
  (let* ((total 0)
         (count (length specs))
         (f-string? (make-uniform-vector count #t #f))
         (f-pad?    (make-uniform-vector count #t #f))
         (f-ubyte?  (make-uniform-vector count #t #f))
         (f-ushort? (make-uniform-vector count #t #f))
         (table (make-array #f count 3)))

    (define (name-index name)
      (let loop ((i 0))
        (cond ((= count i) (error "no such field:" name))
              ((eq? name (array-ref table i 0)) i)
              (else (loop (1+ i))))))

    (define (touches i)
      (array-ref table i 1))

    (define (touched i)
      (array-ref table i 2))

    (define (grok i prev name bytes . opts)
      (define (yes! bv)
        (uniform-vector-set! bv i #t))
      (array-set! table name i 0)
      (let ((string? (memq 'string opts))
            (pad? (memq name '(-pad %pad)))
            (signed? (memq 'signed opts)))
        (or string? pad?
            (memq bytes '(1 2 4 8))
            (error "(make-fwt grok): invalid spec" bytes specs))
        (set! total (+ total bytes))
        (and string?                   (yes! f-string?))
        (and pad?                      (yes! f-pad?))
        (and (not signed?) (= 1 bytes) (yes! f-ubyte?))
        (and (not signed?) (= 2 bytes) (yes! f-ushort?))
        (let ((cur (and (not (or string? pad?))
                        (case bytes
                          ((1) #\nul)
                          ((2) (if signed? 's 'S))
                          ((4) (if signed? -1 1))
                          ((8) 'l)))))
          (cond ((not cur)
                 bytes)
                ((and (pair? prev) (eq? cur (car prev)))
                 (set-cdr! prev (1+ (cdr prev)))
                 prev)
                (else
                 (cons cur 1))))))

    (let ((bufs (let ((prevs (accumulator)))
                  (let loop ((prev #f) (i 0) (specs specs))
                    (or (null? specs)
                        (let ((cur (apply grok i prev (car specs))))
                          (or (eq? prev cur) (prevs cur))
                          (loop cur (1+ i) (cdr specs)))))
                  (map (lambda (x)
                         (if (pair? x)
                             (make-uniform-vector
                              (cdr x) (let ((proto (car x)))
                                        (if (eq? 'S proto)
                                            's
                                            proto))
                              0)
                             (make-string x #\nul)))
                       (prevs))))
          (manip (vector
                  ;; 0-2: spew? #t
                  (lambda (s buf)
                    (or (eq? s buf)
                        (substring-move! s 0 (string-length s) buf 0)))
                  (lambda (n name)
                    (error "PADDING!" name))
                  (lambda (n buf ri)
                    (uniform-vector-set! buf ri n))
                  ;; 3-7: spew? #f
                  (lambda (buf)
                    buf)
                  (lambda ()
                    0)
                  (lambda (buf ri)
                    (let ((rv (uniform-vector-ref buf ri)))
                      (if (negative? rv)
                          (+ 256 rv)
                          rv)))
                  (lambda (buf ri)
                    (let ((rv (uniform-vector-ref buf ri)))
                      (if (negative? rv)
                          (+ 65536 rv)
                          rv)))
                  uniform-vector-ref))
          (i 0))
      (define (yes? bv)
        (uniform-vector-ref bv i))
      (define (t-string?) (yes? f-string?))
      (define (t-pad?)    (yes? f-pad?))
      (define (t-ubyte?)  (yes? f-ubyte?))
      (define (t-ushort?) (yes? f-ushort?))
      (define (!! n . x)
        (array-set! table (vector-ref manip n) i 1)
        (array-set! table                   x  i 2))
      (FE bufs (lambda (buf)
                 (define (touch! ri)
                   (if spew?
                       (cond ((t-string?) (!! 0 buf))
                             ((t-pad?)    (!! 1 (array-ref table i 0)))
                             (else        (!! 2 buf ri)))
                       (cond ((t-string?) (!! 3 buf))
                             ((t-pad?)    (!! 4))
                             ((t-ubyte?)  (!! 5 buf ri))
                             ((t-ushort?) (!! 6 buf ri))
                             (else        (!! 7 buf ri))))
                   (set! i (1+ i)))
                 (if (string? buf)
                     (touch! 0)
                     (FE (iota (uniform-vector-length buf)) touch!))))
      ;; rv
      (fwt<- total (lambda (k)
                     (let ((i (map name-index k)))
                       (values (map touches i)
                               (map touched i))))
             bufs))))

(define (fwt-total fwt)
  (ra1d-ref fwt 0))

(define (list<- x)
  ;; (ttn-do zzz publishing) uses ‘list?’; this is faster/sloppier.
  (if (pair? x)
      x
      (list x)))

(define (fwt-put fwt k v)
  (let-values (((touch touched) ((ra1d-ref fwt 1) (list<- k))))
    (FE touch (list<- v) touched apply)))

(define (fwt-get fwt alist)
  (let-values (((touch touched) ((ra1d-ref fwt 1) (map car alist))))
    (FE alist (map apply touch touched) set-cdr!)))

(define (fwt-send! fd fwt)
  (or (zero? (fwt-total fwt))
      (let ((iov (ra1d-ref fwt 2)))
        (while (writev fd iov)))))

(define (fwt-recv! fd fwt)
  (let ((iov (ra1d-ref fwt 2)))
    (define (next)
      (let ((got (readv fd iov)))
        (and got (not (zero? got)) got)))
    (while (next))))

;;;---------------------------------------------------------------------------
;;; build structure

(define (!!! s . args)
  (let ((reason (apply fs s args)))
    (fse "~A~%" reason)
    (throw 'internal-error reason)))

(define (width x)
  (cond ((and (pair? x) (number? (car x))) (car x))
        ((hash-ref ENUMS x) (width 'CARD32))
        ((vector? x) (* (vector-ref x 0) (width (vector-ref x 1))))
        (else (hash-ref WIDTH x))))

(define (substruct type)
  (and=> (hash-ref STRUCTS type)
         (lambda (segments)
           (or (= 1 (length segments))
               (!!! "substruct has multiple segments: ~S" segments))
           (or (eq? 'fixed (caar segments))
               (!!! "substruct segment not ‘fixed’: ~S" (car segments)))
           ;; fields
           (cdar segments))))

(define (up4 n)
  (logand 3 (- n)))

(define alloc+pbuf
  (let ((v (list->vector (map (lambda (n)
                                (make-string n #\nul))
                              (iota 4)))))
    (lambda (n)
      (let ((pad (up4 n)))
        (values (+ n pad) (if (zero? pad)
                              '()
                              (list (vector-ref v pad))))))))

(define (make-uve/o-fwt bytes len buf)
  (let-values (((alloc pbuf) (alloc+pbuf (* bytes len))))
    (fwt<- alloc #f `((,buf 0 . ,len)
                      ,@pbuf))))

(define (make-uve/i-fwt bytes len signed?)
  (let-values (((alloc pbuf) (alloc+pbuf (* bytes len))))
    (let ((buf (make-uniform-vector len (case bytes
                                          ((1) #\nul)
                                          ((2) 's)
                                          ((4) (if signed? -1 1))
                                          ((8) 'l))
                                    0)))
      (fwt<- alloc (lambda (k-ignored)
                     (values (list identity)
                             (list (list buf))))
             `(,buf
               ,@pbuf)))))

(define %XA-INTEGER 19)                 ; gross

(define (new-structure spew? name . skip)

  (define (mkfwt specs) (make-fwt spew? specs))
  (define (mk1fwt spec) (make-fwt spew? (list spec)))

  (set! skip (and (not (null? skip)) (car skip)))
  (let ((segments (or (hash-ref STRUCTS name)
                      (!!! "no such structure ‘~A’" name)))
        (xname (and (pair? name) (car name)))
        (segmap '())
        (bans (accumulator))
        (info (make-object-property))
        (all-m+v<-v (hash-ref MASKS name)))

    (define (fixed? seg)
      (eq? 'fixed (car seg)))

    (define (w x)
      (or (and xname (width (cons xname (list<- x))))
          (width x)))

    (define (m+v<-v fname v)
      (let* ((enum-name (or (assq-ref all-m+v<-v fname)
                            (!!! "struct ‘~A’ mask-value field ‘~A’ fubar!"
                                 name fname)))
             (enum (hash-ref ENUMS enum-name))
             (ordered (sort (map (lambda (k value)
                                   (cons (assq-ref enum k) value))
                                 (map car v)
                                 (map cdr v))
                            (lambda (a b)
                              (< (car a) (car b))))))
        (cons (apply + (map (lambda (pair)
                              (ash 1 (car pair)))
                            ordered))
              (map cdr ordered))))

    (define (fixed-info fields names types extra)
      (let ((ls (accumulator))
            (non-prim '(-pad %pad))
            (tot 0)
            (kids (or spew? (accumulator))))

        (define (flat name type opts)
          (define (ls! nbytes . etc)
            (set! tot (+ tot nbytes))
            (ls (cons* name nbytes etc)))
          (cond ((substruct type)
                 => (lambda (fields)
                      (set! non-prim (cons name non-prim))
                      (let* ((kid-names (map car fields))
                             (flat-names (map (lambda (kid-name)
                                                (symbol-append
                                                 name '/ kid-name))
                                              kid-names)))
                        (or spew? (kids (values name flat-names kid-names)))
                        (FE flat-names
                            (map cadr fields)
                            (map cddr fields)
                            flat))))
                ((and (vector? type)
                      (or (number? (vector-ref type 0))
                          (!!! "field ‘~A’ type malformed: ~S" name type))
                      (= 1 (w (vector-ref type 1))))
                 (ls! (vector-ref type 0) 'string))
                (else
                 (apply ls! (w type) (if (memq type SIGNED)
                                         (cons 'signed opts)
                                         opts)))))

        (FE names types extra flat)
        (let* ((specs (if skip
                          (list-tail (ls) skip)
                          (ls)))
               (dingleberry (up4 tot))
               (full-specs (if (zero? dingleberry)
                               specs
                               (append specs `((%pad ,dingleberry)))))
               (fwt (mkfwt full-specs)))
          (if spew?
              (values (+ tot dingleberry)
                      (and (memq '%length names) full-specs)
                      fwt)
              (values (lset-difference eq? (if skip
                                               (list-tail names skip)
                                               names)
                                       non-prim)
                      (kids) fwt)))))

    (define (array-info fields names types extra)
      ;; always 1
      (let* ((field (car fields))
             (name (car names))
             (v (car types))
             (len-expr (vector-ref v 0))
             (type (vector-ref v 1))
             (opts (if (= 2 (vector-length v))
                       '()
                       (list (vector-ref v 2)))))
        (define (no x)
          (if (pair? x)
              (or (eq? 'quote (car x))
                  (FE x no))
              (and (assq x segmap)
                   (not (memq x (bans)))
                   (bans x))))
        (no len-expr)
        ;; Use ‘eq?’ because sometimes ‘(w type)’ => #f.
        `(,(if (eq? 1 (w type)) 'string type)
          ,name ,len-expr ,@opts)))

    (define (spew!)
      (let* ((tot 0)
             (req-full-specs #f)
             (rejam-k '())
             (rejam-v '())
             (everything
              (list->vector
               (map (lambda (seg)
                      (and (fixed? seg)
                           (let-values (((partial full-specs fwt) (info seg)))
                             (set! tot (+ tot partial))
                             (and full-specs (set! req-full-specs full-specs))
                             fwt)))
                    segments)))
             (var-s-i (remove (lambda (ent)
                                (memq (car ent) (bans)))
                              segmap)))

        (define (all  index)       (vector-ref  everything index))
        (define (all! index value) (vector-set! everything index value))

        (define (jam! alist)

          (define (jam-fixed! s-i k v)
            (cond (req-full-specs
                   (set! rejam-k (append (list<- k) rejam-k))
                   (set! rejam-v (append (list<- v) rejam-v))))
            (fwt-put (all s-i) k v))

          (define (jam-array! s-i seg k v)
            (define (jam-array-informedly! type name down-name . opts)
              (define (jam-down! n)
                (and down-name
                     (let ((down-i (assq-ref segmap down-name)))
                       (cond ((zero? down-i)
                              (set! rejam-k (cons down-name rejam-k))
                              (set! rejam-v (cons n rejam-v))))
                       (fwt-put (all down-i)
                                down-name
                                n))))
              (cond ((substruct type)
                     (and=>
                      (assq-ref alist name)
                      (lambda (sub-alist)
                        (all!
                         s-i
                         (map (lambda (sa)
                                (let-values (((jam! out!) (jam!/out! type)))
                                  (set! tot (+ tot (jam! sa)))
                                  out!))
                              sub-alist))
                        (jam-down! (length sub-alist)))))
                    ((memq 'mask opts)
                     (let* ((m+v (m+v<-v name v))
                            (v (cdr m+v))
                            (len (length v))
                            (width (w type))
                            (indices (iota len))
                            (alist (map (lambda (idx)
                                          `(,idx ,width))
                                        (iota len)))
                            (fwt (mkfwt (map (lambda (idx)
                                               `(,idx ,width))
                                             indices))))
                       (all! s-i fwt)
                       (fwt-put fwt indices v)
                       (set! tot (+ tot (* len width)))
                       (jam-down! (car m+v))))
                    ((eq? 'string type)
                     (let* ((len (string-length v))
                            (alloc (+ len (up4 len)))
                            (fwt (mk1fwt `(,name ,alloc string))))
                       (all! s-i fwt)
                       (fwt-put fwt k v)
                       (set! tot (+ tot alloc))
                       (jam-down! len)))
                    ((equal?
                      ;; We use very specific conditions to reduce the
                      ;; probability of silent incorrectness for near-matches.
                      '(ChangeProperty data void)
                      (list xname name type))
                     (let* ((len (uniform-vector-length v))
                            (format (case (array-prototype v)
                                      ((#\a #\nul) 8)
                                      ((s) 16)
                                      ((-1 1) 32)))
                            (fwt (make-uve/o-fwt (ash format -3) len v)))
                       (all! s-i fwt)
                       (set! tot (+ tot (fwt-total fwt)))
                       (fwt-put (all 0)
                                '(format data-len)
                                (list format len))))
                    (else
                     (!!! "TODO: ~A ‘~A’ (width ~A ~A ~A)"
                          type name (w type) (if (memq 'mask opts)
                                                 'mask
                                                 'count)
                          down-name))))

            (apply-to-args (info seg) jam-array-informedly!))

          (let ((bins '()))
            (FE (map car alist) (map cdr alist)
                (lambda (k v)
                  (let* ((s-i (or (assq-ref var-s-i k)
                                  (error "bad field:" k)))
                         (bin (cdr (or (assq s-i bins)
                                       (let ((new (list s-i '() '())))
                                         (set! bins (cons new bins))
                                         new)))))
                    (set-car! bin (cons k (car bin)))
                    (set-car! (cdr bin) (cons v (cadr bin))))))
            (FE (sort-list! bins (lambda (a b)
                                   (> (car a) (car b))))
                (lambda (bin)
                  (apply-to-args
                   bin (lambda (s-i k v)
                         (let ((seg (list-ref segments s-i)))
                           (if (fixed? seg)
                               (jam-fixed! s-i k v)
                               (jam-array! s-i seg (car k) (car v)))))))))
          (and req-full-specs
               (let ((nwords (ash tot -2)))
                 (and (< 65535 nwords)
                      (let ((fwt (mkfwt `(,@(list-head req-full-specs 2)
                                          (%extended-length-flag 2)
                                          (%length 4)
                                          ,@(list-tail req-full-specs 3)))))
                        (set! nwords (1+ nwords))
                        (fwt-put fwt
                                 (cons '%extended-length-flag rejam-k)
                                 (cons 0 rejam-v))
                        (all! 0 fwt)))
                 (fwt-put (all 0) '%length nwords)))
          tot)

        (define (out! fd)
          (array-for-each
           (lambda (x)
             (cond ((not x))
                   ((fwt? x) (fwt-send! fd x))
                   (else (FE x (lambda (sub-out!)
                                 (sub-out! fd))))))
           everything))

        ;; rv
        (values jam! out!)))

    (define (fill! fd . init)
      (let ((rv (accumulator)))

        (define (compute x)
          (cond ((number? x) x)
                ((eq? 'length x) (assq-ref (rv) '%reply-length))
                ((symbol? x) (or (assq-ref (rv) x) (eval x)))
                ((pair? x) (if (eq? 'quote (car x))
                               (cadr x)
                               (apply (compute (car x))
                                      (map compute (cdr x)))))))

        (define (fill-fixed! seg)
          (let-values (((prim kids fwt) (info seg)))
            (define (populate fields)
              (let ((alist (map list fields)))
                (fwt-get fwt alist)
                alist))
            (fwt-recv! fd fwt)
            (apply rv (populate prim))
            (FE kids (lambda (v)
                       (let-values (((k suba actual) v))
                         (set! suba (populate suba))
                         (FE suba actual set-car!)
                         (rv (cons k suba)))))))

        (define (fill-array-informedly! type name up-name . opts)
          (let ((len (compute up-name)))
            (cond ((number? len))
                  (else (set! type (vector-ref len 1))
                        (set! len (compute (vector-ref len 0)))))
            (cond ((eq? 'STR type)
                   (let ((ptot 0)
                         (v (make-vector len (whatever)))
                         (slen-fwt (mk1fwt '(#f 1)))
                         (slen-alist (list (cons #f #f)))
                         (slen (whatever))
                         (s-fwt (whatever))
                         (s-alist (list (cons #f #f))))
                     (do ((i 0 (1+ i)))
                         ((= i len))
                       (fwt-recv! fd slen-fwt)
                       (fwt-get slen-fwt slen-alist)
                       (set! slen (cdar slen-alist))
                       (set! ptot (+ ptot 1 slen))
                       (set! s-fwt (mk1fwt `(#f ,slen string)))
                       (fwt-recv! fd s-fwt)
                       (fwt-get s-fwt s-alist)
                       (vector-set! v i (cdar s-alist)))
                     (set! ptot (up4 ptot))
                     (or (zero? ptot)
                         (begin (set! s-fwt (mk1fwt `(%pad ,ptot)))
                                (fwt-recv! fd s-fwt)))
                     (rv `(,name . ,v))))
                  ((hash-ref STRUCTS type)
                   (let ((sub-get (new-structure #f type))
                         (v (make-vector len 0)))
                     (do ((i 0 (1+ i)))
                         ((= i len))
                       (vector-set! v i (sub-get fd)))
                     (rv `(,name . ,v))))
                  ((eq? 'string type)
                   (let ((fwt (mk1fwt `(,name ,(+ len (up4 len)) string))))
                     (fwt-recv! fd fwt)
                     (let ((pair (cons name (whatever))))
                       (fwt-get fwt (list pair))
                       (set-cdr! pair (string-take (cdr pair) len))
                       (rv pair))))
                  ((w type)
                   => (lambda (n)
                        (let* ((fwt (make-uve/i-fwt n len (memq type SIGNED)))
                               (alist (list (list name))))
                          (fwt-recv! fd fwt)
                          (fwt-get fwt alist)
                          (set! alist (car alist))
                          (set-cdr! alist (array->list (cdr alist)))
                          (rv alist))))
                  ((eq? 'void type)
                   (let* ((n (ash (assq-ref (rv) 'format) -3))
                          (len (assq-ref (rv) 'value-len))
                          (opts (if (= %XA-INTEGER (assq-ref (rv) 'type))
                                    '(signed)
                                    '()))
                          (alist (if (= 1 n)
                                     `((0 ,(+ len (up4 len))
                                          string))
                                     (map (lambda (idx)
                                            `(,idx ,n ,@opts))
                                          (iota len))))
                          (pad (and (= 2 n)
                                    (let ((diff (up4 (* n len))))
                                      (and (positive? diff)
                                           diff))))
                          (fwt (mkfwt (if pad
                                          (append alist `((%pad ,pad)))
                                          alist))))
                     (fwt-recv! fd fwt)
                     (fwt-get fwt alist)
                     (and (= 1 n)
                          (set-cdr! (car alist) (string-take (cdar alist) len)))
                     (rv `(,name ,@(map cdr alist)))))
                  (else
                   (!!! "TODO: ~A ‘~A’ (width ~A count ~A (~A))"
                        type name (w type) len up-name)))))

        (apply rv init)
        (FE segments
            (lambda (seg)
              (if (fixed? seg)
                  (fill-fixed! seg)
                  (apply-to-args (info seg) fill-array-informedly!))))
        (rv)))

    ;; Compute segmap and assign the appropriate info-* proc.
    (FE segments (iota (length segments))
        (lambda (seg s-idx)
          (let-values (((type fields) (car+cdr seg)))
            (FE (map car fields)
                (lambda (name)
                  (set! segmap (acons name s-idx segmap))))
            (set! (info seg)
                  ((case type
                     ((fixed) fixed-info)
                     ((array) array-info))
                   fields
                   (map car fields)
                   (map cadr fields)
                   (map cddr fields))))))
    ;; This is hardly elegant.
    (if spew?
        (spew!)
        fill!)))

(define (jam!/out! name)
  (new-structure #t name))

(define (request-out! name major minor data)
  (let-values (((jam! out!) (jam!/out! name)))
    (jam! `((%major-opcode . ,major)
            ,@(if minor `((%minor-opcode . ,minor)) '())
            ,@data))
    out!))

;;;---------------------------------------------------------------------------
;;; i/o

(define (recv-fixed-proc spec)
  (let ((fwt (make-fwt #f spec))
        (alist (map list (map car spec)))
        (get (if (= 1 (length spec))
                 car
                 identity)))
    (lambda (fd)
      (fwt-recv! fd fwt)
      (fwt-get fwt alist)
      (get (map cdr alist)))))

(define recv-one-byte (recv-fixed-proc '((%one-byte 1))))

(define bitvector<-string
  (let ((masks (list->vector (map (lambda (pos)
                                    (ash 1 pos))
                                  (iota 8)))))
    (lambda (s offset)
      (let* ((on (accumulator))
             (slen (string-length s))
             (v (make-uniform-vector (+ offset (* 8 slen)) #t #f)))
        (FE (map char->integer (string->list s))
            (lambda (n)
              (do ((i 0 (1+ i)))
                  ((= 8 i))
                (or (zero? (logand n (vector-ref masks i)))
                    (on (+ offset i))))
              (set! offset (1+ offset))))
        (bit-set*! v (list->uniform-vector 1 (on)) #t)
        v))))

(define (make-io-manager fd)
  (let ((serial 1)
        (serial-high-prev 0)
        (serial-high-current 0)
        (recv-error-code (recv-fixed-proc '((%hint 1))))
        (recv-partial (recv-fixed-proc '((%minor 1)
                                         (%sequence-number 2))))
        (handle-error #f)
        (xevq #f)
        (rra 0)                         ; requests requiring answer
        (stale-rdq-window-size 2)
        (evq (q-make))
        (rdq (q-make))
        (wrq (q-make)))

    (define (recv-error)
      (let* ((hint (recv-error-code fd))
             (err-name (hash-ref ERRORS hint))
             (get (new-structure #f err-name 2)))
        `((%error-name . ,(car err-name)) ,@(get fd))))

    (define (flush!)
      (or (q-empty? wrq)
          (let ((ready (select '() (list fd) '())))
            (and (memq fd (cadr ready))
                 (let ((ent (deq! wrq)))
                   ((cdr ent) fd)
                   (flush!))))))

    (define (wr! out! ans-name)
      (enq! wrq (cons serial out!))
      (enq! rdq (list serial ans-name))
      (and ans-name (set! rra (1+ rra)))
      (let ((rv serial))
        (and (zero? (logand #xffff serial))
             (begin (set! serial-high-prev serial-high-current)
                    (set! serial-high-current serial)))
        (set! serial (1+ serial))
        rv))

    (define (gobble!)

      (define (find-rdq-ent seqlo)
        (let ((ents (car rdq)))
          (or (assq (logior serial-high-current seqlo) ents)
              (assq (logior serial-high-prev seqlo) ents))))

      (define (id<-seqlo seqlo)
        (logior seqlo (if (or (q-empty? rdq)
                              (> seqlo (logand #xffff (caaar rdq))))
                          serial-high-current
                          serial-high-prev)))

      (define (hang seqlo stuff)
        (cond ((find-rdq-ent seqlo)
               => (lambda (ent)
                    (or (zero? rra) (set! rra (1- rra)))
                    (set-cdr! ent (append! (cdr ent) (list stuff)))))
              ((assq '%error-name stuff)
               ((or handle-error
                    (lambda (x)
                      (fse "UNHANDLED-X-PROTOCOL-ERROR: ~S~%" x)
                      (exit #f)))
                `((%id . ,(id<-seqlo seqlo)) (%current-serial . ,serial)
                  ,@stuff)))
              (else
               (enq! rdq (list (id<-seqlo seqlo) #:spurious stuff)))))

      (define (get-alist name skip . ffval)
        (apply (new-structure #f name skip)
               fd
               (if (null? ffval)
                   '()
                   ;; TODO: Learn "first field not padding" check.
                   (let ((ff (caadr (cdar (hash-ref STRUCTS name)))))
                     (if (memq ff '(-pad %pad))
                         '()
                         `((,ff . ,(car ffval))))))))

      (define (read/dispatch one)

        (define (read/handle-event eid detail)
          (let* ((ev-name (hash-ref EVENTS (logand #x7f one)))
                 (data (if detail
                           ;; normal
                           (get-alist ev-name 3 detail)
                           ;; KeymapNotify kludge part 2: special read/munge
                           ;; TODO: export bitvector<-string
                           ;;       (app can call it on demand)
                           (list (bitvector<-string
                                  (cdar (get-alist ev-name 1))
                                  8))))
                 (ev (cons* eid (car ev-name)
                            (zero? (logand #x80 one))
                            data)))
            (if xevq
                (xevq ev)
                (enq! evq ev))))

        (cond ((zero? one)
               (let* ((alist (recv-error))
                      (pair (assq '%sequence-number alist)))
                 (hang (cdr pair) (delq! pair alist))))
              ;; KeymapNotify kludge part 1: recognize KeymapNotify
              ((= 11 (logand #x7f one))
               (read/handle-event serial #f))
              (else
               (let* ((pair (recv-partial fd))
                      (two (car pair))
                      (seqlo (cadr pair)))
                 (cond ((and (= 1 one) (find-rdq-ent seqlo))
                        => (lambda (ent)
                             (hang seqlo (get-alist (cadr ent) 3 two))))
                       ((= 1 one)
                        (!!! "unexpected answer: minor ~A id ~A rdq ~S~%"
                             two (id<-seqlo seqlo) (car rdq)))
                       (else
                        (read/handle-event (id<-seqlo seqlo) two)))))))

      (and (memq fd (car (select (list fd) '() '() 0)))
           (read/dispatch (recv-one-byte fd)))
      (or (q-empty? rdq)
          (let ((ok (- serial stale-rdq-window-size rra)))
            (let loop ((stale (deq! rdq)))
              (if (> ok (car stale))
                  (begin
                    (and (cadr stale)
                         (fso "WARNING: discarding stale: ~S~%" stale))
                    (loop (deq! rdq)))
                  (q-push! rdq stale)))))
      (and (not (q-empty? rdq))
           ;; Ignore false positives.
           (->bool (any cadr (car rdq)))))

    (define (rd! id)
      (let loop ((head (deq! rdq)))
        (cond ((= id (car head)) head)
              (else (and (cadr head)
                         (fso "WARNING: (looking for ~A) discarding: ~S~%"
                              id head))
                    (and (not (q-empty? rdq))
                         (loop (deq! rdq)))))))

    (define (reject! ent)
      (q-push! rdq ent))

    (define (set-stale-rdq-window-size! n)
      (set! stale-rdq-window-size n))

    (define (set-error-handler! proc)
      (set! handle-error proc))

    (define (set-xevq! new)
      (set! xevq (cond ((not new) #f)
                       ((procedure? new) new)
                       ((q? new) (lambda (ev)
                                   (enq! new ev)))
                       (else (!!! "bad external event queue spec: ~S"
                                  new))))
      (let loop ()
        (or (q-empty? evq)
            (begin (and xevq (xevq (deq! evq)))
                   (loop)))))

    (lambda (command . args)
      (apply (case command
               ((#:flush!) flush!)
               ((#:wr!) wr!)
               ((#:gobble!) gobble!)
               ((#:rd!) rd!)
               ((#:reject!) reject!)
               ((#:set-stale-rdq-window-size!) set-stale-rdq-window-size!)
               ((#:set-error-handler!) set-error-handler!)
               ((#:set-external-event-queue!) set-xevq!)
               (else (!!! "bad command: ~S" command)))
             args))))

(define io (make-object-property))

;;;---------------------------------------------------------------------------
;;; extensions

(define (make-extension-manager io-mgr)

  (define (q req ans major . etc)
    (let ((id (io-mgr #:wr! (request-out! req major #f etc) ans)))
      (io-mgr #:flush!)
      (while (not (io-mgr #:gobble!)))
      (caddr (io-mgr #:rd! id))))

  (let ((avail (map string->symbol
                    (vector->list
                     (-x 'names
                         (q '(ListExtensions req)
                            '(ListExtensions ans)
                            99)))))     ; aka ListExtensions
        (info (make-hash-table 5)))

    (define (extension-info name)
      (and (memq name avail)
           (or (hashq-ref info name)
               (hashq-set!
                info name
                (let ((alist (q '(QueryExtension req)
                                '(QueryExtension ans)
                                98      ; aka QueryExtension
                                `(name . ,(symbol->string name)))))
                  (map (lambda (field)
                         (-x field alist))
                       '(major-opcode
                         first-event
                         first-error)))))))

    (define (major-opcode name)
      (and=> (extension-info name) car))

    ;; First (maybe), enable BIG-REQUESTS.
    (and (memq 'BIG-REQUESTS avail)
         ;; TODO: Communicate ‘maximum-request-length’ to ‘new-structure’
         ;;       (which, unfortunately, entails its redesign).
         (q '(BIG-REQUESTS Enable req)
            '(BIG-REQUESTS Enable ans)
            (+ 0                        ; aka (BIG-REQUESTS Enable)
               (major-opcode 'BIG-REQUESTS))))
    ;; rv
    (lambda (command arg)
      (case command
        ((#:major-opcode) (major-opcode arg))
        ((#:first-event) (and=> (extension-info arg) cadr))
        ((#:first-error) (and=> (extension-info arg) caddr))
        ((#:avail?) (if (eq? #t arg)
                        avail
                        (memq arg avail)))))))

(define xm (make-object-property))

;;;---------------------------------------------------------------------------
;;; high

(define (alist<-plist plist)
  (let ((ls (accumulator)))
    (let loop ((plist plist))
      (or (null? plist)
          (let ((k (car plist))
                (v (cadr plist)))
            (ls (cons (if (pair? k)
                          (alist<-plist k)
                          k)
                      (cond ((pair? v) (alist<-plist v))
                            ((vector? v) (map alist<-plist (vector->list v)))
                            (else v))))
            (loop (cddr plist)))))
    (ls)))

(define (plist<-kwlist kwlist)
  (let ((ls (accumulator)))
    (let loop ((kwlist kwlist))
      (or (null? kwlist)
          (let ((k (car kwlist))
                (v (cadr kwlist)))
            (ls (if (symbol? k)
                    k
                    (keyword->symbol k)))
            (ls (cond ((pair? v) (plist<-kwlist v))
                      ((vector? v) (list->vector
                                    (map plist<-kwlist
                                         (vector->list v))))
                      (else v)))
            (loop (cddr kwlist)))))
    (ls)))

;; Return a procedure that manages (simply) i/o on @var{conn}.
;; See @code{-synchronous-request-proc} for documentation on @var{opts}.
;;
;; The returned procedure has the signature @code{(one . rest)};
;; behavior is controlled by the first arg @var{one}, with @var{rest}
;; having subsequent meanings.  Here is a table:
;;
;; @table @asis
;; @item #:gobble!
;; Check @var{conn} and read pending input onto the read queue.  Return
;; @code{#t} if the read queue is non-empty (which may be the case from
;; prior operations).
;;
;; @item #:flush!
;; Send the contents of the write queue to @var{conn}.
;;
;; @item #:set-stale-rdq-window-size! n
;; By default, the read queue maintains a two-entry window for
;; handling ``stale'' messages from the server.  If you see the
;; @samp{unexpected answer} error, it means the server has sent a
;; message whose serial id has passed beyond stale (to ``forgotton'').
;; In that case, try increasing the window size with this command.
;;
;; @item #:set-error-handler! handler
;; By default, spurious errors, i.e., those not or no-longer associated
;; with a request, are displayed to stderr and the program exits
;; failurefully.
;;
;; This specifies instead that @var{handler}, a procedure, should be
;; called with one argument, an alist of error details, including
;; (but not limited to) keys @code{%id}, @code{%current-serial} and
;; @code{%error-name}.  The difference in values of the first two
;; gives you an idea of how far back in the protocol stream the error
;; happened.
;;
;; If @var{handler} is @code{#f}, revert to default behavior.
;;
;; @item #:set-external-event-queue! handler
;; Initially, events are added to an internal queue (DWR: without bound!).
;; This sends them, one by one, to @var{handler}, and arranges for
;; @var{handler} to receive future events.  @var{handler} can be
;; a queue object (satisfying @code{(ice-9 q) q?}); a procedure
;; that takes one argument; or @code{#f} to resume internal queuing.
;;
;; @item @var{request} data[...]
;; Add to the write queue the @var{request} (a symbol) with fields
;; specified by @var{data}.  Return a cookie that identifies the
;; request.  See @code{-synchronous-request-proc} for documentation
;; on the data format.
;;
;; @item @var{cookie}
;; Wait until a reply (or error) associated with @var{cookie} is
;; available and return it (FIXME: there may be multiple errors,
;; but this only returns the first error or reply).
;; @end table
;;
(define (-simple-io-manager conn . opts)
  (let* ((io-mgr (io (vector-ref conn 0)))
         (ext-mgr (xm (vector-ref conn 0)))
         (kw? (memq 'keyword-style opts))
         (munge (if (or kw? (memq 'plist-input opts))
                    alist<-plist
                    identity)))

    (define (make-request name data)
      (let ((core? (symbol? name)))
        (let-values (((opcode ans-name) (car+cdr
                                         (or (hash-ref REQUESTS name)
                                             (!!! "not a request: ~S" name)))))
          (io-mgr #:wr! (request-out!
                         (append (if core?
                                     (list name)
                                     name)
                                 '(req))
                         (if core?
                             opcode
                             (ext-mgr #:major-opcode (car name)))
                         (and (not core?) opcode)
                         (munge data))
                  ans-name))))

    (define (receive-reply cookie)
      (let loop ()
        (while (not (io-mgr #:gobble!)))
        (let ((ans (io-mgr #:rd! cookie)))
          (cond ((or (not ans) (null? (cddr ans)))
                 (and ans (io-mgr #:reject! ans))
                 (loop))
                (else
                 (caddr ans))))))

    ;; rv
    (lambda (one . rest)
      (cond ((memq one '(#:gobble!
                         #:flush!
                         #:set-stale-rdq-window-size!
                         #:set-error-handler!
                         #:set-external-event-queue!))
             (apply io-mgr one rest))
            ((null? rest)
             (receive-reply one))
            (kw?
             (make-request one (plist<-kwlist rest)))
            (else
             (make-request one (car rest)))))))

;; Return a procedure that can do a @dfn{synchronous request} on @var{conn}.
;; Normally, the procedure takes two arguments, @var{name} and @var{alist}.
;; These specify a request, such as @code{PolySegment} (a symbol);
;; and the data to fill in the fields of that request.
;;
;; Some fields cannot be specified (including them in @code{alist}
;; is an error), while others are computed automatically.  The
;; rest default to 0 (zero).
;;
;; If the request has no expected reply, the procedure returns @code{#f}.
;; Otherwise, it awaits the reply and returns it as an alist.
;;
;; @var{opts} are symbols that configure the procedure.
;;
;; @table @code
;; @item plist-input
;; Specifies that the procedure should take a list of alternating
;; symbols and values (a plist) as the second arg.
;;
;; @item keyword-style
;; Specifies that the procedure should take any number of args
;; after the name, as alternating keywords and values.
;; @end table
;;
;; A value may be an integer, or a vector of sub-alists (or
;; plists, or kwlists, as appropriate).
;;
(define (-synchronous-request-proc conn . opts)
  (let* ((kw? (memq 'keyword-style opts))
         (simple (apply -simple-io-manager conn
                        `(,@(if kw? '(plist-input) '())
                          ,@(delq 'keyword-style opts)))))

    (define (two name data)
      (let ((cookie (simple name data)))
        (simple #:flush!)
        (and (cdr (hash-ref REQUESTS name))
             (simple cookie))))

    (if kw?
        (lambda (command . form)
          (two command (plist<-kwlist form)))
        two)))

;; Connect to the X @var{server}.  If @var{server} is omitted,
;; use the value of the env var @code{DISPLAY}.
;;
;; If there are problems, display a reason to the current error
;; port and return @code{#f}.  Otherwise, return a @dfn{connection
;; object}, a vector of the form:
;;
;; @example
;; #(PORT SETUP EXTENSIONS)
;; @end example
;;
;; @var{port} is the socket used for low-level communication.
;; Accessing it directly is probably a good way to screw things up;
;; You Have Been Warned!
;; @var{setup} is an alist detailing @code{server} specifics.
;; @var{extensions} is a list of extensions (each a symbol) available
;; on the server.
;;
;; The env var @code{XAUTHORITY} names a file to be read for
;; authorization records.  Presently, this has only been tested
;; with auth type @code{MIT-MAGIC-COOKIE-1}.
;;
;;-args: (- 1 0)
;;
(define (-connect . server)
  (let* ((d (or (and (not (null? server))
                     (car server))
                (getenv "DISPLAY")))
         (colon (string-index d #\:))
         (host (and (not (zero? colon))
                    (car (hostent:addr-list
                          (gethost (string-take d colon))))))
         (display (substring d (1+ colon)
                             (or (string-index d #\.)
                                 (string-length d)))))

    (define (tcp)
      (let* ((port (+ 6000 (string->number display)))
             (sock (socket PF_INET SOCK_STREAM 0)))
        (connect sock PF_INET host port)
        sock))

    (define (unix)
      (let ((name (fs "/tmp/.X11-unix/X~A" display))
            (sock (socket PF_UNIX SOCK_STREAM 0)))
        (connect sock AF_UNIX name)
        sock))

    (define (authorization)

      ;; DWR: reckless!
      (define (read-auth-file filename)
        (and=> (and (access? filename R_OK)
                    (open-input-file filename))
               (lambda (p)
                 (define (short)
                   (let ((uve (make-uniform-vector 1 's 0)))
                     (uniform-vector-read! uve p)
                     (ntohs (uniform-vector-ref uve 0))))
                 (define (counted-string)
                   (let ((s (make-string (short))))
                     (uniform-vector-read! s p)
                     s))
                 (define (next)
                   (let ((family (short)))
                     (list family
                           (if (zero? family)
                               (let ((uve (make-uniform-vector 1 1 0)))
                                 (or (= 4 (short)) (error "WTF!"))
                                 (uniform-vector-read! uve p)
                                 (ntohl (uniform-vector-ref uve 0)))
                               (counted-string))
                           (counted-string)
                           (counted-string)
                           (counted-string))))
                 (let ((auths (accumulator)))
                   (let loop ()
                     (or (eof-object? (peek-char p))
                         (begin (auths (next))
                                (loop))))
                   (close-port p)
                   (auths)))))

      (and=> (and=> (getenv "XAUTHORITY") read-auth-file)
             (lambda (ls)
               (let ((addrs (and host (hostent:addr-list (gethost host)))))
                 (or-map (lambda (ent)
                           (and (or (not host)
                                    (and (zero? (car ent))
                                         (memq (cadr ent) addrs)))
                                (string=? display (caddr ent))
                                (list-tail ent 3)))
                         ls)))))

    (define (get-setup fd)
      (let ((auth (authorization)))
        (let-values (((jam! out!) (jam!/out! 'SetupRequest)))
          (jam! (alist<-plist
                 `(byte-order
                   ,(char->integer (if (= 1 (ntohs 1)) #\B #\l))
                   protocol-major-version
                   11
                   protocol-minor-version
                   0
                   authorization-protocol-name
                   ,(if auth (car auth) "")
                   authorization-protocol-data
                   ,(if auth (cadr auth) ""))))
          (out! fd)))
      (let loop ()
        (or (memq fd (car (select (list fd) '() '() 0)))
            (begin (usleep 100000)
                   (loop))))
      ((new-structure #f (if (zero? (recv-one-byte fd))
                             'SetupFailed
                             'Setup)
                      1)
       fd))

    (let* ((port (cond (host (tcp))
                       (else (unix))))
           (fd (fileno port))
           (setup (get-setup fd)))
      (fcntl port F_SETFD FD_CLOEXEC)
      (cond ((assq-ref setup 'reason)
             => (lambda (reason)
                  (let* ((p (current-error-port))
                         (fp (make-fso p)))
                    (shutdown port 2)
                    (close-port port)
                    (fp "Could not connect to display ~A -- ~A" d reason)
                    (or (zero? (port-column p)) (newline p))
                    #f)))
            (else
             (let* ((io-mgr (make-io-manager fd))
                    (ext-mgr (make-extension-manager io-mgr)))
               (set! (io port) io-mgr)
               (set! (xm port) ext-mgr)
               (vector port setup (ext-mgr #:avail? #t))))))))

;; Return @var{x} (-: which marks the spot :-) from the alist @var{tree}.
;; @var{x} can take many forms:
;;
;; @table @asis
;; @item @code{()}
;; Return @var{tree}.
;;
;; @item @var{symbol}
;; Return @code{(assq-ref @var{tree} @var{x})}.
;;
;; @item @var{integer}
;; Return @code{(vector-ref @var{tree} @var{x})}.
;;
;; @item @var{list}
;; Use @code{(car @var{x})} to extract a subtree and recurse
;; on it with @code{(cdr @var{x})}.  For example:
;;
;; @example
;; (define CONN (-connect))
;; (define SETUP (vector-ref CONN 1))
;; (-x '(roots 0 width-in-pixels) SETUP) @result{} 1280
;; @end example
;; @end table
;;
(define (-x x tree)                     ; (-: marks the spot :-)
  (cond ((null? x) tree)
        ((symbol? x) (assq-ref tree x))
        ((integer? x) (vector-ref tree x))
        (else (let ((sub (-x (car x) tree)))
                (-x (cdr x) sub)))))

;; Return a new 32-byte string made by packing event @var{type} (a symbol)
;; data @var{alist}, suitable for the value of the @code{event} field in a
;; @code{SendEvent} protocol request.
;;
;; If @var{alist} contains keys that do not correspond to fields
;; in the event @var{type}, signal "invalid alist fields" error.
;;
;; As a special case, if @var{type} is @code{ClientMessage} and
;; an @var{alist} key is @code{/client-message-data}, the associated
;; value should be a list of integers in the format specified in the
;; @code{format} field:
;;
;; @example
;; @multitable @columnfractions .15 .30 .25
;; @headitem format @tab max list length @tab valid value range
;; @item  8 @tab 20 @tab [0,#xff]
;; @item 16 @tab 10 @tab [0,#xffff]
;; @item 32 @tab  5 @tab [0,#xffffffff]
;; @end multitable
;; @end example
;;
;; If the format is not recognized, or if the list of numbers is
;; too long, signal error.
;;
(define (-wire<-event type alist)
  (let* ((code (or (hash-ref EVENTS type)
                   (error "no such event type:" type)))
         (rv (make-string 32 #\nul)))
    (define (byte! i n)
      (string-set! rv i (integer->char n)))
    (define (pack! i w n)
      (case w
        ((1)
         (byte! i (logand #xff n)))
        ((2)
         (set! n (htons (logand #xffff n)))
         (byte!     i     (ash n -8))
         (byte! (1+ i) (logand n #xff)))
        ((4)
         (set! n (htonl (logand #xffffffff n)))
         (byte!    i    (logand #xff (ash n -24)))
         (byte! (+ i 1) (logand #xff (ash n -16)))
         (byte! (+ i 2) (logand #xff (ash n  -8)))
         (byte! (+ i 3) (logand #xff      n)))
        (else
         (error "WTF! w:" w))))
    (byte! 0 code)
    (let loop ((specs (cddar (hash-ref STRUCTS (append (list<- type) '(ev)))))
               (i 1))
      (or (null? specs)
          (null? alist)
          (let* ((spec (car specs))
                 (field (car spec))
                 (ftype (cadr spec))
                 (w (width ftype)))
            (and=> (assq field alist)
                   (lambda (val)
                     (set! alist (delq val alist))
                     (set! val (cdr val))
                     (pack! i w val)))
            (loop (cdr specs) (+ i w)))))
    ;; Special case ‘ClientMessageData’, sigh.
    (and (eq? 'ClientMessage type)
         (and=> (assq '/client-message-data alist)
                (lambda (val)
                  (set! alist (delq val alist))
                  (set! val (cdr val))
                  ;; The byte-offset 1 is for the field ‘format CARD8’.
                  (let ((w (char->integer (string-ref rv 1))))
                    (if (memq w '(8 16 32))
                        (set! w (ash w -3))
                        (error "bad ClientMessage format:" w))
                    (let loop ((ls val)
                               (i 12))
                      (cond ((null? ls))
                            ((= 32 i)
                             (error "too much /client-message-data:" ls))
                            (else
                             (pack! i w (car ls))
                             (loop (cdr ls) (+ i w)))))))))
    (or (null? alist)
        (error "invalid alist fields:" (map car alist)))
    rv))

;; Return direct access to internal data structure @var{table} (a symbol).
;; These should be treated as read-only, and best avoided unless you
;; don't mind having to dig into the source a bit.  Valid tables are:
;;
;; @table @code
;; @item ENUMS
;; Hash table mapping symbols to alists.
;; The alist in turn maps symbols to integers.
;; @item MASKS
;; Hash table mapping struct names to alists.
;; The alist in turn maps field names to enum names (both symbols).
;; @item ERRORS
;; Hash table mapping error names to error codes (integers).
;; @item EVENTS
;; Hash table mapping event names to opcodes (integers).
;; @item REQUESTS
;; Hash table mapping request names to opcodes (integers).
;; @end table
;;
;; Note that struct, event and request names may be a simple symbol
;; such as @code{SCREEN}; or a list of symbols, such as
;; @code{(Composite RedirectSubwindows req)}.  Also, for every
;; request there may be up to two structs, one whose name ends
;; with @code{req}, and (possibly) one with @code{ans}.
;;
;; Use @code{hash-ref} for hash tables.
;;
(define (-internal-data name)
  (case name
    ((ENUMS) ENUMS)
    ((MASKS) MASKS)
    ((ERRORS) ERRORS)
    ((EVENTS) EVENTS)
    ((REQUESTS) REQUESTS)
    (else (error "No such table:" name))))

;; Return the type (a symbol) of @var{event}.
;; This uses the @code{EventMask} enum.
;;
(define (-event-type event)
  (cadr event))

;; Return @code{#f} if @var{event} originated from the server,
;; or @code{#t} if it was generated due to a @code{SendEvent} request.
;;
(define (-event-synthetic? event)
  (not (caddr event)))

;; Return the @var{event} data, an alist.
;;
(define (-event-data event)
  (cdddr event))

;; Disconnect from @var{conn}.
;; Using @var{conn} afterwards is an error.
;;
(define (-disconnect conn)
  (let ((port (vector-ref conn 0)))
    (set! (xm port) #f)
    (set! (io port) #f)
    (shutdown port 2)
    (close-port port))
  (vector-fill! conn #f)
  (gc)
  #t)

;;;---------------------------------------------------------------------------
;;; what cost, experience?

(load (in-vicinity (dirname (port-filename (current-load-port)))
                   "x-protocol.LEARNINGS"))

;;; x-protocol.scm ends here