ref: 2cfe3c2c1cb0de08ef9a4dca2d22dac286736b09
dir: /gen.rkt/
#!/usr/bin/env racket
#lang racket
(require (for-syntax racket/format))
(require (for-syntax syntax/parse))
(require (for-syntax racket/contract))
(require (for-syntax racket/string))
(require racket/contract)
(require racket/generic)
(define for-posix? (make-parameter #f))
(define in-dir (make-parameter "."))
(define out-dir (make-parameter "."))
(command-line #:program "gen.rkt"
#:once-each [("--for-posix") BOOL "Generate for POSIX" (for-posix? BOOL)]
[("--in-dir") DIR "Where *.in files are located" (in-dir DIR)]
[("--out-dir") DIR "Where the generated files should be stored" (out-dir DIR)])
(define types '()) ; base types set
(define cmplxs '()) ; complex types set
(define tagged '()) ; complex types set that also have a defined tag
(define size-in-bits/c
(make-contract #:name 'size-in-bits/c #:first-order (λ (x) (member x '(8 16 24 32 64)))))
(define tag/c
(make-contract #:name 'tag/c #:first-order (λ (x) (and (string? x) (= 4 (string-length x))))))
(define/contract (indent lst)
(-> (listof any/c) (listof string?))
(map (λ (str) (string-append " " str)) (flatten lst)))
(define/contract (c-typedef? s)
(-> string? boolean?)
(string-prefix? s "typedef"))
(define/contract (extra-context-ref? ref)
(-> symbol? boolean?)
(string-prefix? (symbol->string ref) "o->"))
(define/contract (enum? e)
(-> symbol? boolean?)
(regexp-match? #rx"^[A-Z][A-Z0-9_]+$" (symbol->string e)))
(define (format f #:on-all [allfun identity])
(define-values (a b) (partition c-typedef? (flatten (map f cmplxs))))
(define ps (list a b (map f types) ""))
(string-join (allfun (flatten ps)) "\n"))
(define (verb-hex bits)
(if (for-posix?) (~a "%#\"PRIx" bits "\"") "%#ux"))
(define (verb-unsigned bits)
(if (for-posix?) (~a "%\"PRIu" bits "\"") "%ud"))
(define (fmt-expr e)
(define (fmt e)
(cond
[#f #f]
[(number? e) e]
[(list? e)
(match e
[(list op x y) (~a "(" (fmt x) (if (equal? op 'bor) "|" op) (fmt y) ")")])]
[(and (symbol? e) (or (enum? e) (extra-context-ref? e))) (~a e)]
[(symbol? e) (~a "v->" e)]))
(and e (fmt e)))
(define-generics code
(gen-h code) ; generates code for the C header
(gen-c code b index) ; generates code for the C source file
(c-type code)) ; type name to be used in C
(define-struct type (name bits c verb fmtarg parse)
#:transparent
#:methods gen:code
[(define (gen-h t)
empty)
(define (gen-c t b index)
empty)
(define (c-type t)
(type-c t))])
(define (type-string? t)
(and (type? t) (equal? (type-c t) 'char)))
(define/contract (type-size t)
(-> type? positive?)
(/ (type-bits t) 8))
(define (block stmt lst)
(if (= (length lst) 1) (list* stmt lst) (list (string-append stmt "{") lst "}")))
(define (fmt-ref ref)
(if (symbol? ref) (~a (if (extra-context-ref? ref) "" "v->") ref) (fmt-expr ref)))
(define (wrap-cond-c cond lst)
(match cond
[#f lst]
[(list op ref n ...)
#:when ((listof number?) n)
(block (~a "if(" (string-join (map (λ (n) (~a (fmt-ref ref) " " op " " n)) n) " || ") ")")
(indent lst))]
[(list op ref e) (block (~a "if(" (fmt-expr cond) ")") (indent lst))]))
(define (invert-c op)
(match op
['== '!=]
['<= '>]
['>= '<]
['< '>=]
['> '<=]))
(define-struct field (type name attrs)
#:transparent
#:methods gen:code
[(define/generic super-c-type c-type)
(define (gen-h f)
(define cnt (field-count f))
(define fixed-array (number? cnt))
(define is-ptr (and (cmplx? (field-type f)) (field-offset f)))
(list (~a (if (field-unused? f) "// " "")
(super-c-type (field-type f))
" "
(if (or is-ptr (and cnt (not fixed-array))) "*" "")
(field-name f)
(if fixed-array (~a "[" cnt "];") ";"))))
(define (gen-c f b index)
(define (size t)
(if (type? t) (type-size t) 0))
(define (name t)
(if (type? t) (super-c-type t) (cmplx-name t)))
(define ref (~a (if (field-unused? f) "" "v->") (field-name f)))
(define declared (and (field-unused? f) (not (empty? (field-test f)))))
(define (format-number x)
(if (<= x 32768) (~r x) (~r x #:base 16 #:sign '("0x" "" "-0x"))))
(define (parse-if-error read)
(define t (field-type f))
(define is-ptr (and (cmplx? (field-type f)) (field-offset f)))
(match (field-count f)
[#f
(if (or declared (not (field-unused? f)))
(if index
(list (~a (if declared (~a (name (field-type f)) " ") "")
ref
" = "
((type-parse (field-type f)) b index)
";")
(if (field-context? f) (~a "o->" (field-name f) " = " ref ";") empty))
(list
(if declared
(~a (name (field-type f)) " " ref ";")
(if is-ptr (~a ref " = calloc(1, sizeof(*" ref "));") empty))
(~a "if(read_" (name (field-type f)) "(o, " (if is-ptr "" "&") ref ") < 0){")))
(if index empty (~a "if(otfreadn(o, " (size (field-type f)) ") == nil){")))]
[count
#:when (type-string? t)
(list (~a "if((b = otfreadn(o, " count ")) == nil)")
(~a " goto err;")
(if (equal? t String-UTF16)
(list (~a ref " = malloc(" count "/2+1);")
(~a "utf16to8((u8int*)" ref ", " count "/2+1, b, " count ");"))
(~a ref " = strtoutf8(o, b, " count ");")))]
[count
#:when (type? t)
(if (field-unused? f)
empty
(list (if (number? count) empty (~a ref " = malloc(" count "*sizeof(*" ref "));"))
(~a "for(int i = 0; i < " count "; i++)")
(~a " "
ref
"[i] = "
((type-parse (field-type f)) b index (~a "i*" (size (field-type f))))
";")))]
[count
(~a "if(otfarray(o, &"
ref
", read_"
(super-c-type (field-type f))
", sizeof("
(super-c-type (field-type f))
"), "
count
") < 0){")]))
(define (test-cond ts)
(map (λ (t)
(match t
[(list 'test op a ...)
(string-join (map (λ (v) (~a ref " " (invert-c op) " " (format-number v))) a)
" && ")]))
ts))
(define (at lst)
(define at (field-offset f))
(if (not at)
lst
(list (~a "if(" (fmt-expr at) " != 0){")
(~a " if(otfpushrange(o, " (fmt-expr at) ", -1) < 0)")
(~a " goto err;")
(indent lst)
(~a " if(otfpoprange(o) < 0)")
(~a " goto err;")
(~a "}"))))
(at (list*
(parse-if-error #t)
(if index
empty
(list (~a " werrstr(\"%s: %r\", \"" (field-name f) "\");") (~a " goto err;") (~a "}")))
(match (test-cond (field-test f))
[(list) empty]
[(list a ...)
(list (~a "if(" (string-join a " || ") "){")
(~a " werrstr(\"%s: invalid value: %d ("
(verb-hex 32)
")\", \""
(field-name f)
"\", "
ref
", "
ref
");")
(~a " goto err;")
(~a "}"))]))))])
(define/contract (field-attr f a)
(-> field? symbol? any)
(define v (assoc a (field-attrs f)))
(and v (cadr v)))
(define (field-unused? f)
(field-attr f 'unused))
(define (field-verb f)
(field-attr f 'verb))
(define (field-offset f)
(field-attr f 'at))
(define (field-cond f)
(define v (assoc 'cond (field-attrs f)))
(and v (rest v)))
(define (field-context? f)
(field-attr f '->o))
(define (field-bits f)
(field-attr f 'bits))
(define/contract (field-count f)
(-> field? (or/c false/c number? string?))
(fmt-expr (field-attr f 'count)))
(define (field-test f)
(filter (λ (t) (eq? (car t) 'test)) (field-attrs f)))
(define (field-print-c f)
(define t (field-type f))
(define cnt (and (not (type-string? t)) (field-count f)))
(define basic-array (and cnt (type? t)))
(define fixed-array (and basic-array (number? cnt)))
(define array-index (if cnt "[i]" ""))
(define verb (if (type? t) (or (field-verb f) (type-verb t)) ""))
(define fmtarg (if (type? t) (type-fmtarg t) identity))
(define bits (field-bits f))
(define bits-verbs (or (and bits (string-join (make-list (hash-count bits) "%s") "")) ""))
(define bits-args
(or (and bits
(string-join
(hash-map (field-bits f)
(λ (bit enum)
(~a "(v->" (field-name f) array-index "&" enum ")?\" " enum "\":\"\"")))
", "
#:before-first ", "))
""))
(define print-index
(if basic-array
(~a "f->print(f->aux, \"%*s%s[%d]: "
verb
bits-verbs
"\\n\", indent, \"\", \""
(field-name f)
"\", i, "
(fmtarg (~a "v->" (field-name f) array-index))
bits-args
");")
(~a "f->print(f->aux, \"%*s%s[%d]:\\n\", indent, \"\", \"" (field-name f) "\", i);")))
(define array-loop
(if cnt
(λ (lst)
(block (~a "for(int i = 0; i < " cnt "; i++)")
(indent (list* print-index (if basic-array empty lst)))))
identity))
(define is-ptr (and (cmplx? t) (field-offset f) (not cnt)))
(define lst
(flatten (list (if (type? t)
(~a "f->print(f->aux, \"%*s%s: "
verb
bits-verbs
"\\n\", indent, \"\", \""
(field-name f)
"\", "
(fmtarg (~a "v->" (field-name f) array-index))
bits-args
");")
(list (if cnt
empty
(~a "f->print(f->aux, \"%*s%s:\\n\", indent, \"\", \""
(field-name f)
"\");"))
(if is-ptr (~a "if(v->" (field-name f) " != nil)") empty)
(~a (if is-ptr " " "")
"print_"
(cmplx-name t)
"(f, indent+indentΔ, o, "
(if is-ptr "" "&")
"v->"
(field-name f)
array-index
");"))))))
(if (field-unused? f) empty (wrap-cond-c (field-cond f) (array-loop lst))))
(define (filter-extra extra key)
(flatten (filter-map (λ (e) (and (eq? (car e) key) (cdr e))) extra)))
(define-struct cmplx (name fields tag extra after)
#:transparent
#:methods gen:code
[(define/generic super-gen-h gen-h)
(define/generic super-gen-c gen-c)
(define (gen-h c)
(define allbits
(filter-map (λ (f)
(define bits (field-bits f))
(and bits
(list (~a "// " (field-name f))
(hash-map bits (λ (bit enum) (~a enum " = 1<<" bit ","))))))
(cmplx-fields c)))
(define enums
(if (empty? allbits)
empty
(list (~a "enum { // " (cmplx-name c)) (indent allbits) (~a "};") (~a ""))))
(flatten (append (list (~a "typedef struct " (cmplx-name c) " " (cmplx-name c) ";")
(~a "")
enums
(~a "struct " (cmplx-name c) " {"))
(indent (map super-gen-h (cmplx-fields c)))
(indent (filter-extra (cmplx-extra c) 'field))
(list (~a "};")
(~a "")
(~a "int read_" (cmplx-name c) "(Otf *o, " (cmplx-name c) " *v);")
(~a "void print_"
(cmplx-name c)
"(Otfile *f, int indent, Otf *o, "
(cmplx-name c)
" *v);")))))
(define (gen-c c b index)
(define (no-vla? f)
(define cnt (field-count f))
(or (not cnt) (number? cnt)))
; group fields to minimize number of reads
; complex types are always alone
; simple types can be combined unless versioned
; versioned simple types are combined if the check is the same
(define (group-fields fields)
(define (combine? f g)
(or (empty? g)
(and (type? (field-type f))
(type? (field-type (car g)))
(not (or (field-offset f) (field-offset (car g))))
(no-vla? f)
(no-vla? (car g))
(equal? (field-cond f) (field-cond (car g))))))
(define (group- g fields)
(match fields
[(list-rest f tail)
(if (combine? f g) (group- (cons f g) tail) (cons (reverse g) (group- (list f) tail)))]
[_ (list (reverse g))]))
(group- empty fields))
(define (field-size f)
(match (field-count f)
[#f (type-size (field-type f))]
[count
#:when (type? (field-type f))
((if (number? count) (λ (sz) (* count sz)) (λ (sz) (~a count "*" sz)))
(type-size (field-type f)))]))
(define (add x y)
(match (list x y)
[(list _ 0) x]
[(list 0 _) y]
[_ (if (and (number? x) (number? y)) (+ x y) (~a x "+" y))]))
(define (parse-group g)
(define (p fs index)
(if (pair? fs)
(cons (super-gen-c (car fs) "b" index) (p (cdr fs) (add index (field-size (car fs)))))
empty))
(p g 0))
(define (gen-group-c fields)
(define unused (andmap field-unused? fields))
(wrap-cond-c
(field-cond (car fields))
(if (cmplx? (field-type (car fields)))
(map (λ (f) (super-gen-c f #f #f)) fields)
(let* ([sum (foldr (λ (f accu) (add (field-size f) accu)) 0 fields)]
[lst (flatten (list (if (field-offset (car fields))
empty
(list (~a "if((b = otfreadn(o, " sum ")) == nil)")
(~a " goto err;")
(if unused "USED(b);" empty)))
(parse-group fields)))])
lst))))
(flatten
(append
(list (~a "")
(~a "int")
(~a "read_" (cmplx-name c) "(Otf *o, " (cmplx-name c) " *v)")
(~a "{")
(~a " u8int *b = nil; USED(b);"))
(indent (map gen-group-c (group-fields (cmplx-fields c))))
(indent (filter-extra (cmplx-extra c) 'read))
(list (~a " return 0;")
(~a "err:")
(~a " werrstr(\"%s: %r\", \"" (cmplx-name c) "\");")
(~a " return -1;")
(~a "}"))
(list (~a "")
(~a "void")
(~a "print_" (cmplx-name c) "(Otfile *f, int indent, Otf *o, " (cmplx-name c) " *v)")
(~a "{")
(indent (map field-print-c (cmplx-fields c)))
(indent (filter-extra (cmplx-extra c) 'print))
(~a " USED(o);")
(~a "}")))))
(define (c-type c)
(cmplx-name c))])
(define/contract (autoparse bits ctype)
(-> positive? symbol? procedure?)
(λ (b [index 0] [offset #f])
(define off (if offset (~a "+" offset) ""))
(define cast (~a "(" ctype ")"))
(define (f index bits)
(define sh (- bits 8))
(define tail (if (positive? sh) (~a "<<" sh " | " (f (add1 index) sh)) ""))
(~a (if (> sh 24) cast "") b "[" index off "]" tail))
(f index bits)))
(define-for-syntax typenames '())
(define (c-friendly-name t #:downcase [downcase #f])
(define (f t)
(string-replace (string-trim ((if downcase string-downcase identity) t))
"/"
(if (for-posix?) "" "∕")))
(if (symbol? t) (string->symbol (f (symbol->string t))) (f t)))
(define-syntax (mktype stx)
(syntax-parse stx
[(_ typ:id bits c:id verb:expr) #'(mktype typ bits c verb (autoparse bits `c))]
[(_ typ:id bits c:id verb:expr parse:expr)
#:declare bits (expr/c #'size-in-bits/c #:name "size in bits")
(begin
(set! typenames (cons (syntax-e #`typ) typenames))
#'(begin
(define typ
(make-type `typ
bits.c
`c
(if (pair? verb) (car verb) verb)
(if (pair? verb) (cdr verb) identity)
parse))
(set! types (append types (list typ)))))]))
(define-syntax (mkcmplx stx)
(syntax-parse stx
[(_ typ:id
fields:expr ...+
(~optional (~seq #:tag tag))
(~optional (~seq #:extra extra:expr))
(~optional (~seq #:after after)))
#:declare tag (expr/c #'tag/c #:name "table tag")
(begin
(set! typenames (cons (syntax-e #`typ) typenames))
#'(begin
(define tag- (~? (~@ tag.c) #f))
(define typ
(make-cmplx (c-friendly-name `typ)
(mkfields [~@ fields] ...)
tag-
(~? (~@ extra) empty)
(~? (~@ after) empty)))
(set! cmplxs (append cmplxs (list typ)))
(when tag-
(set! tagged (append tagged (list typ))))))]))
(define-for-syntax fields '())
(define-syntax (mkattr stx)
(define-syntax-class compop
#:description "comparison operator"
(pattern op:id
#:when (member (syntax-e #'op) '(== != < > <= >=))))
(define-syntax-class arithop
#:description "arithmetical operator"
(pattern op:id
#:when (member (syntax-e #'op) '(+ - / * & bor))))
(define-syntax-class oref
#:description "extra context field reference"
(pattern oref:id
#:when (string-prefix? (symbol->string (syntax-e #'oref)) "o->")))
(define-syntax-class ref
#:description "field reference"
(pattern ref:id
#:fail-when (not (assoc (syntax-e #'ref) fields)) "no such field"
#:with type (cadr (assoc (syntax-e #'ref) fields))))
(syntax-parse stx
[(_ type name {~literal ->o}) #''(->o #t)]
[(_ _ _ ({~literal at} ref:ref))
#:fail-when (not (type-offset? (syntax-e #'ref.type))) "can't be used as an offset"
#''(at ref)]
; FIXME - check fields and ops/numbers
[(_ _ _ ({~literal at} e:expr)) #''(at e)]
[(_ type _ {~literal hex})
#:fail-when (not (type-number? (syntax-e #'type))) "not a number type"
#'(list 'verb (verb-hex (type-bits type)))]
[(_ type _ (p:compop vs:number ...+))
#:fail-when (not (type-comparable? (syntax-e #'type))) "type can't be used in a comparison"
#''(test p vs ...)]
[(_ _ _ (p:compop ref:ref vs:number ...+))
#''(cond
p
ref
vs ...)]
[(_ _ _ (p:compop oref:oref e:expr)) ; FIXME - check fields and ops/numbers
#''(cond
p
oref
e)]
[(_ _ _ (p:compop e:expr ...+)) ; FIXME - check fields and ops/numbers
#''(cond
p
e ...)]
[(_ _ _ {~literal unused}) #''(unused #t)]
[(_ _ _ (oref:oref)) #''(count oref)]
[(_ _ _ (ref:ref))
#:fail-when (not (type-index? (syntax-e #'ref.type))) "can't be used as index to an array"
#''(count ref)]
[(_ _ _ (n:number)) #''(count n)]
[(_ _ _ ({~literal bits} ht:expr)) #'(list 'bits ht)]
[(_ _ _ (p:arithop e:expr ...+)) #''(count (p e ...))])) ; FIXME - check fields and ops/numbers
(define-syntax (mkfield stx)
(define-syntax-class name
#:description "field name"
(pattern name:id
#:fail-when (assoc (syntax-e #'name) fields) "duplicate field name"))
(define-syntax-class type
#:description "field type"
(pattern type:id
#:fail-when (not (member (syntax-e #'type) typenames)) "unknown field type"))
(syntax-parse stx
[(_ type:type name:name attrs ...)
(begin
(set! fields (cons (syntax->datum #'(name type)) fields))
#'(field type
`name
(list (mkattr type `name [~@ attrs]) ...)))]))
(define-syntax (mkfields stx)
(syntax-parse stx
[(_ x ...+)
(begin
(set! fields '())
#'(list (mkfield [~@ . x]) ...))]))
(require racket/include)
(include "otf.rkt")
(define (out path f)
(call-with-output-file path
#:exists 'truncate/replace
(λ (p)
(begin
(current-output-port p)
(f)))))
(define (at dir name)
(simplify-path (build-path (dir) name)))
(out (at out-dir "otf.h")
(λ ()
(printf "#line 1 \"otf.h.in\"\n")
(printf "~a" (port->string (open-input-file (at in-dir "otf.h.in")) #:close? #t))
(printf "\n")
(printf "~a" (format gen-h))))
(define (extra-context-fields c)
(if (cmplx? c)
(filter-map (λ (f) (and (field-context? f) (indent (gen-h f)))) (cmplx-fields c))
empty))
(out (at out-dir "otfpriv.h")
(λ ()
(begin
(define c-data (port->lines (open-input-file (at in-dir "otfpriv.h.in")) #:close? #t))
(define extra-fields-index (index-of c-data "OTF_EXTRA_FIELDS"))
(define extra-fields-data
(string-append (format extra-context-fields #:on-all remove-duplicates)
(~a "#line " (+ extra-fields-index 2) "\"otfpriv.h.in\"")))
(printf "#line 1 \"otfpriv.h.in\"\n")
(for-each (λ (s) (printf "~a\n" s)) (list-set c-data extra-fields-index extra-fields-data))
(printf "\n"))))
(out (at out-dir "otf.c")
(λ ()
(printf "#line 1 \"otf.c.in\"\n")
(printf "~a" (port->string (open-input-file (at in-dir "otf.c.in")) #:close? #t))
(printf "\n")
(printf "~a" (format (λ (c) (gen-c c #f #f))))))