(or (= 2 (length (command-line)))
(error "x-protocol.learn: missing arg (directory of .eaab files)"))
(or (and (file-exists? (cadr (command-line)))
(file-is-directory? (cadr (command-line))))
(error "x-protocol.learn: bad directory:" (cadr (command-line))))
(primitive-load "./personally.scm")
(primitive-load "0gx/forms-from.scm")
(use-modules
((ice-9 rdelim) #:select (write-line))
((srfi srfi-13) #:select (string-take))
((ttn-do zzz personally) #:select (accumulator
whatever
FE fs fso))
((ttn-do zzz 0gx forms-from) #:select (forms<-file))
((ice-9 pretty-print) #:select (pretty-print)))
(define SEEN (accumulator))
(define WIDTH (make-hash-table 797))
(define SIGNED (list))
(define AKA (make-hash-table 17))
(define XIDTYPES (accumulator))
(define ENUMS (make-hash-table 107))
(define STRUCTS (make-hash-table 757))
(define SEGSIGS (make-hash-table 7))
(define ERRORS (make-hash-table 19))
(define EVENTS (make-hash-table 43))
(define XIDUNIONS (make-hash-table 5))
(define UNIONS (make-hash-table 5))
(define COMBINE-ADJACENTS (accumulator))
(define REQUESTS (make-hash-table 439))
(define MASKS (make-hash-table 31))
(define (learn filename)
(let* ((form (car (forms<-file filename)))
(expected-car (or (eq? 'xcb (car form))
(error "syntax error in" filename)))
(top-attributes (cadr form))
(stats (make-hash-table 7))
(import-prefixes (accumulator))
(xname #f)
(name #f))
(define (bad! s . args)
(error (apply fs s args)))
(define (slot head attr . body)
(define (h! ht k v)
(and (hash-ref ht k)
(bad! "~A `~A' collision!" head k))
(hash-set! ht k v))
(define (aref k)
(assq-ref attr k))
(define (expect-null-body!)
(or (null? body)
(bad! "~A~A body not null: ~S"
head (if (unspecified? name)
""
(fs " `~A'" name))
body)))
(define (expect-null-attr!)
(or (null? attr)
(bad! "~A `~A' attr not null: ~S"
head name attr)))
(define (check-attr condition)
(or condition (bad! "strange ~A `~A' attr: ~S" head name attr)))
(define (n<-value node)
(caddr node))
(define (partial-eval-op node)
(cons (let ((op (assq-ref (cadr node) 'op)))
(case op
((+ - * /) op)
((&) 'logand)
(else (bad! "~A: ~A `~A' unknown op: ~S"
filename head name op))))
(map (lambda (x)
(case (car x)
((op) (partial-eval-op x))
((fieldref) (caddr x))
((value) (n<-value x))
(else (bad! "~A: ~A `~A' unknown operand: ~S"
filename head name x))))
(cddr node))))
(define (canontype x)
(let ((s (and (symbol? x) (symbol->string x))))
(cond ((and s (string-index s #\:))
=> (lambda (colon)
(let ((one (string->symbol (string-take s colon)))
(two (string->symbol (substring s (1+ colon)))))
(set! one (assq-ref (SEEN) one))
(set! x (if (eq? 'xproto one)
two
(list one two))))))))
(or (hash-ref WIDTH x)
(let ((norm (if (pair? x) x (list x))))
(or-map (lambda (prefix)
(let ((try (cons prefix norm)))
(and (hash-ref WIDTH try)
(begin (set! x try)
#t))))
(import-prefixes))))
x)
(define (width x)
(set! x (canontype x))
(or (and (vector? x)
(or (hash-ref WIDTH x)
(let ((len (vector-ref x 0)))
(and (number? len)
(and=> (width (vector-ref x 1))
(lambda (w)
(let ((ans (* len w)))
(hash-set! WIDTH x ans)
ans)))))))
(hash-ref WIDTH x)))
(define (crunch-struct sname verbose . fill)
(let ((count (length verbose))
(serial 0)
(segments (accumulator))
(seg-type #f)
(seg #f))
(define (form x)
(let ((type (if (or (not (vector? (cadr x)))
(width (cadr x)))
'fixed
'array)))
(or (and (not (eq? 'array type))
(eq? type seg-type))
(begin
(set! seg-type type)
(set! seg (accumulator))
(segments (cons seg-type seg))))
(seg x)))
(define (examine x no)
(let ((t-attr (cadr x)))
(define (tref k)
(assq-ref t-attr k))
(form
(case (car x)
((pad)
`(-pad #(,(tref 'bytes) BYTE)))
((field)
`(,(tref 'name)
,(let ((type (canontype (tref 'type))))
(cond ((eq? 'ClientMessageData type)
(vector `(assq-ref '((8 . #(20 CARD8))
(16 . #(10 CARD16))
(32 . #(5 CARD32)))
format)
type))
((width type) type)
((= count no) (vector 1 type))
(else (bad! "~A `~A' field `~A': unknown width"
head name type))))))
((list)
(let* ((lname (tref 'name))
(type (canontype (tref 'type)))
(what (and (= 3 (length x))
(caddr x)))
(kind (and what (car what))))
(case kind
((fieldref value)
`(,lname ,(vector (caddr what) type)))
((op)
`(,lname ,(vector `(/ ,(partial-eval-op what)
,(width type))
type)))
((#f)
`(,lname ,(vector #f type)))
(else
(bad! "~A: ~A `~A' unhandled list `~A' of `~A' (~A)~%"
filename head name lname type kind)))))
((exprfield)
`(,(tref 'name)
,(canontype (tref 'type))
,(partial-eval-op (caddr x))))
((valueparam)
(let ((mtype (tref 'value-mask-type))
(mname (tref 'value-mask-name))
(lname (tref 'value-list-name)))
(form `(,mname ,(canontype mtype)))
`(,lname ,(vector mname 'CARD32 'mask)))) (else
(bad! "~A: ~A `~A' unhandled: ~S~%"
filename head name x))))))
(FE verbose (map 1+ (iota count)) examine)
(set! segments (segments))
(let* ((swidth (make-object-property))
(rv (map (lambda (seg)
(let* ((type (car seg))
(fields ((cdr seg)))
(form (cons type fields)))
(and (eq? 'fixed type)
(set! (swidth form)
(apply + (map width
(map cadr
fields)))))
form))
segments)))
(cond (sname
(and (= 1 (length rv))
(eq? 'fixed (caar rv))
(let ((w (swidth (car rv))))
(if (null? fill)
(h! WIDTH sname w)
(let ((diff (- (car fill) w)))
(cond ((positive? diff)
(hash-set! WIDTH sname (+ w diff))
(append! (car rv)
`((%pad #(,diff BYTE))))))))))
(let ((sig (map car rv)))
(hash-set! SEGSIGS sig
(cons sname (hash-ref SEGSIGS sig '()))))
(h! STRUCTS sname rv)))
rv)))
(define (suffix x)
(append (if (pair? name)
name
(list name))
x))
(hash-set! stats head (1+ (hash-ref stats head 0)))
(set! name (cond ((assq 'name attr)
=> (lambda (pair)
(set! attr (delq! pair attr))
(let ((orig (cdr pair)))
(if xname
(list xname orig)
orig))))
((memq head '(typedef import))
(whatever))
(else
(bad! "~A missing name" head))))
(case head
((xidtype)
(expect-null-attr!)
(expect-null-body!)
(h! WIDTH name (width 'CARD32))
(XIDTYPES name))
((struct)
(expect-null-attr!)
(crunch-struct name body))
((typedef)
(expect-null-body!)
(let ((new (aref 'newname))
(old (aref 'oldname)))
(and xname (set! new (list xname new)))
(h! WIDTH new (width old))
(h! AKA new old)))
((enum)
(expect-null-attr!)
(or (and-map (lambda (x)
(and (pair? x) (eq? 'item (car x))))
body)
(bad! "strange ~A `~A' body: ~S" head name body))
(h! WIDTH name (width 'CARD32)) (h! ENUMS name (map (lambda (x idx)
(cons (assq-ref (cadr x) 'name)
(if (null? (cddr x))
idx
(n<-value (caddr x)))))
body
(iota (length body)))))
((errorcopy)
(check-attr (= 2 (length attr)))
(or (null? body)
(bad! "~A `~A' body non-null" head name body))
(let* ((ref (aref 'ref))
(ref-err (list ref 'err))
(orig (or (hash-ref STRUCTS (cons xname ref-err))
(hash-ref STRUCTS ref-err)
(bad! "~A `~A' ref `~A' unresolvable"
head name ref))))
(h! ERRORS name (aref 'number))
(h! STRUCTS (suffix '(err)) orig)))
((error)
(check-attr (= 1 (length attr)))
(h! ERRORS name (aref 'number))
(crunch-struct
(suffix '(err))
`((field ((type . CARD8) (name . %status)))
(field ((type . CARD8) (name . %hint)))
(field ((type . CARD16) (name . %sequence-number)))
,@body)
32))
((eventcopy)
(check-attr (and-map (lambda (pair)
(memq (car pair) '(number ref)))
attr))
(expect-null-body!)
(let* ((ref (aref 'ref))
(ref-ev (list ref 'ev))
(orig (or (hash-ref STRUCTS (cons xname ref-ev))
(hash-ref STRUCTS ref-ev)
(bad! "~A `~A' ref `~A' unresolvable"
head name ref))))
(h! EVENTS name (aref 'number))
(h! STRUCTS (suffix '(ev)) orig)))
((event)
(check-attr (<= 1 (length attr) 2))
(h! EVENTS name (aref 'number))
(crunch-struct
(suffix '(ev))
`((field ((type . CARD8) (name . %code)))
,(car body)
,@(if (eq? 'true (aref 'no-sequence-number))
'()
'((field ((type . CARD16) (name . %sequence-number)))))
,@(cdr body))
32))
((xidunion)
(expect-null-attr!)
(let ((ls (map caddr body)))
(h! WIDTH name (width 'CARD32))
(h! XIDUNIONS name ls)))
((union)
(expect-null-attr!)
(let ((form (crunch-struct #f body)))
(or (and (= 1 (length form)))
(eq? 'fixed (caar form))
(bad! "~A: ~A `~A' weird!~%body: ~S~%form: ~S~%"
filename head name body form))
(set! form (cdar form))
(h! WIDTH name (apply max (map width (map cadr form))))
(h! UNIONS name form)))
((request)
(check-attr (and-map (lambda (pair)
(memq (car pair) '(opcode combine-adjacent)))
attr))
(and (eq? 'true (aref 'combine-adjacent))
(COMBINE-ADJACENTS name))
(let* ((rev (reverse body))
(reply (and (pair? rev)
(pair? (car rev))
(eq? 'reply (caar rev))
(car rev)))
(reply-name (and reply (suffix '(ans)))))
(h! REQUESTS name (cons (aref 'opcode) reply-name))
(cond (reply (set! body (reverse (cdr rev)))
(or (null? (cadr reply))
(bad! "weird reply (~A `~A') attribute: ~S"
head name (cadr reply)))
(set! reply (cddr reply))))
(crunch-struct
(suffix '(req))
(let ((ext? (pair? name))
(no-body? (null? body)))
`((field ((type . CARD8) (name . %major-opcode)))
,(cond (ext? '(field ((type . CARD8) (name . %minor-opcode))))
(no-body? '(pad ((bytes . 1))))
(else (car body)))
(field ((type . CARD16) (name . %length)))
,@(cond (no-body? '())
(ext? body)
(else (cdr body))))))
(and reply
(crunch-struct
reply-name
`((field ((type . CARD8) (name . %status)))
,(car reply)
(field ((type . CARD16) (name . %sequence-number)))
(field ((type . CARD32) (name . %reply-length)))
,@(cdr reply))
32))))
((import)
(or (= 1 (length body))
(bad! "bad ~A body: ~S" head body))
(let ((need (car body)))
(cond ((assq-ref (SEEN) need) => import-prefixes)
(else (bad! "~A: `~A' needed but not yet imported~%"
filename need)))))
(else
(bad! "~A: UNHANDLED spec element: ~S ~S ~S ~S~%"
head name attr body))))
(define (ta-get! k)
(cond ((assq k top-attributes)
=> (lambda (pair)
(set! top-attributes (delq! pair top-attributes))
(cdr pair)))
(else #f)))
(set! xname (ta-get! 'extension-xname))
(and xname (import-prefixes xname))
(cond ((ta-get! 'header)
=> (lambda (header)
(SEEN (cons header (or xname 'xproto)))))
(else
(bad! "~A: no `header' in top-attributes" filename)))
(FE (cddr form) (lambda (x)
(apply-to-args x slot)))))
(set! SIGNED '(INT8 short INT16 INT32))
(FE '((1 char BOOL BYTE INT8 CARD8)
(2 short INT16 CARD16)
(4 float INT32 CARD32)
(8 double))
(lambda (ent)
(let ((size (car ent)))
(FE (cdr ent)
(lambda (type)
(hash-set! WIDTH type size))))))
(FE '(((CreateWindow req) (value-list . CW))
((ChangeWindowAttributes req) (value-list . CW))
((ConfigureWindow req) (value-list . ConfigWindow))
((CreateGC req) (value-list . GC))
((ChangeGC req) (value-list . GC)))
(lambda (ent)
(hash-set! MASKS (car ent) (cdr ent))))
(let ((eaab-dir (cadr (command-line))))
(FE '(xproto
render
shape
xfixes
bigreq
composite
damage
dpms
glx
randr
record
res
screensaver
shm
sync
xc-misc
xevie
xf86dri
xinerama
xprint
xtest
xv
xvmc)
(lambda (frag)
(learn (in-vicinity eaab-dir (fs "~A.eaab" frag))))))
(define (spew-list name ls)
(newline)
(fso "* (------------------------------------------------ ~A ~A)~%"
name (length ls))
(FE ls write-line))
(define (spew-hash name ht)
(spew-list
name (sort (hash-fold (lambda (k v ls)
(cons (with-output-to-string
(lambda ()
(write-line k)
(pretty-print v)))
ls))
'()
ht)
(lambda (a b)
(define (paren s)
(if (char=? #\( (string-ref s 0)) 1 0))
(let ((ap (paren a))
(bp (paren b)))
((if (zero? (logxor ap bp))
string<?
string>?)
a b))))))
(fso ";;; -*-outline-*-~%")
(pretty-print
'(let ((p (current-load-port)))
(define (next) (read p))
(let top ((x (next)))
(cond ((or (eof-object? x) (not x)))
((eq? '* x)
(let* ((desc (cdr (next)))
(name (car desc))
(stuff-name (and (symbol? name) name))
(stuff (eval stuff-name))
(count (cadr desc))
(type (cond ((hash-table? stuff) 'hash-table)
((procedure? stuff) 'accumulator)
(else 'simple-list)))
(recall (case type
((hash-table)
(lambda ()
(let ((k (next))
(v (next)))
(hash-set! stuff k v))))
((accumulator)
(lambda ()
(stuff (next))))
((simple-list)
(lambda ()
(eval
`(set! ,stuff-name
(cons (quote ,(next))
,stuff-name))))))))
(let again ((count count))
(cond ((zero? count))
(else (recall) (again (1- count)))))
(top (next))))
(else
(fso "WARNING: discarding: ~S~%" x)
(top (next)))))))
(spew-hash "WIDTH" WIDTH)
(spew-hash "ERRORS" ERRORS)
(spew-list "SIGNED" SIGNED)
(spew-hash "ENUMS" ENUMS)
(spew-hash "STRUCTS" STRUCTS)
(spew-hash "EVENTS" EVENTS)
(spew-hash "REQUESTS" REQUESTS)
(spew-hash "MASKS" MASKS)
(FE '(#f
(HFE (k v ERRORS)
(and (symbol? k)
(hash-set! ERRORS v (list k 'err))))
(HFE (k v EVENTS)
(and (symbol? k)
(hash-set! EVENTS v (list k 'ev)))))
pretty-print)