#!/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 in-struct 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-at f))) (list (if (field-in-struct f) (~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 "];") ";")) empty))) (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-at 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 offset (field-offset f)) (define offset-plus (if offset (~a (fmt-expr offset) "+") "")) (define offset-and (if offset (~a (fmt-expr offset) " != 0 && ") "")) (define at (field-at f)) (define count (field-count f)) (if (not at) lst (if (field-array-with-offsets f) (list (~a "if(" offset-and (field-count f) " > 0){") (~a " " ref " = calloc(" count ", sizeof(*" ref "));") (~a " for(int i = 0; i < " count "; i++){") (if offset empty (list (~a " if(" (fmt-expr at) "[i] == 0)") (~a " continue;"))) (~a " if(otfpushrange(o, " offset-plus (fmt-expr at) "[i], -1))") (~a " goto err;") (~a " int r = read_" (name (field-type f)) "(o, " ref "+i);") (~a " if(otfpoprange(o) < 0)") (~a " goto err;") ; FIXME do this only if the field is allowed to fail being read (~a " if(r < 0){") (~a " memset(" ref "+i, 0, sizeof(*" ref "));") (~a " break;") (~a " }") (~a " }") (~a "}")) (list (~a "if(" (fmt-expr at) " != 0){") (~a " if(otfpushrange(o, " offset-plus (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-at f) (field-attr f 'at)) (define (field-offset f) (field-attr f 'offset)) ; returns #t if it's an array with each element having its own; offset pointed to by elements of another array field(define (field-array-with-offsets f) (define v (assoc 'at (field-attrs f))) (define a (caddr v)) (>= (length a) 1)) (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 (field-enum f) (field-attr f 'enum)) (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 bits (λ (bit ename) (~a "(v->" (field-name f) array-index "&" ename ")?\" " ename "\":\"\""))) ", " #:before-first ", ")) "")) (define enum (field-enum f)) (define enum-verbs (or (and enum "%s") "")) (define enum-args (or (and enum (string-join (hash-map enum (λ (val ename) (~a "v->" (field-name f) array-index "==" ename "?\" " ename "\""))) ": " #:before-first ", " #:after-last ":\"\"")) "")) (define print-index (if basic-array (~a "f->print(f->aux, \"%*s%s[%d]: " verb bits-verbs enum-verbs "\\n\", indent, \"\", \"" (field-name f) "\", i, " (fmtarg (~a "v->" (field-name f) array-index)) bits-args enum-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-at f) (not cnt))) (define lst (flatten (list (if (type? t) (list (~a "f->print(f->aux, \"%*s%s: " verb bits-verbs enum-verbs "\\n\", indent, \"\", \"" (field-name f) "\", " (fmtarg (~a "v->" (field-name f) array-index)) bits-args enum-args ");") (if (field-context? f) (~a "o->" (field-name f) " = v->" (field-name f) ";") empty)) (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 optional) #:transparent #:methods gen:code [(define/generic super-gen-h gen-h) (define/generic super-gen-c gen-c) (define (gen-h c) (define valbits (filter-map (λ (f) (define bits (field-bits f)) (and bits (list (~a "// " (field-name f)) (hash-map bits (λ (bit ename) (~a ename " = 1<<" bit ",")))))) (cmplx-fields c))) (define valenums (filter-map (λ (f) (define enum (field-enum f)) (and enum (list (~a "// " (field-name f)) (hash-map enum (λ (val ename) (~a ename " = " val ",")))))) (cmplx-fields c))) (define values (append valbits valenums)) (define enums (if (empty? values) empty (list (~a "enum { // " (cmplx-name c)) (indent values) (~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-at f) (field-at (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-at (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])Lines 1–500 of 698. Load more
#!/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 in-struct 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-at f))) (list (if (field-in-struct f) (~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 "];") ";")) empty))) (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-at 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 offset (field-offset f)) (define offset-plus (if offset (~a (fmt-expr offset) "+") "")) (define offset-and (if offset (~a (fmt-expr offset) " != 0 && ") "")) (define at (field-at f)) (define count (field-count f)) (if (not at) lst (if (field-array-with-offsets f) (list (~a "if(" offset-and (field-count f) " > 0){") (~a " " ref " = calloc(" count ", sizeof(*" ref "));") (~a " for(int i = 0; i < " count "; i++){") (if offset empty (list (~a " if(" (fmt-expr at) "[i] == 0)") (~a " continue;"))) (~a " if(otfpushrange(o, " offset-plus (fmt-expr at) "[i], -1))") (~a " goto err;") (~a " int r = read_" (name (field-type f)) "(o, " ref "+i);") (~a " if(otfpoprange(o) < 0)") (~a " goto err;") ; FIXME do this only if the field is allowed to fail being read (~a " if(r < 0){") (~a " memset(" ref "+i, 0, sizeof(*" ref "));") (~a " break;") (~a " }") (~a " }") (~a "}")) (list (~a "if(" (fmt-expr at) " != 0){") (~a " if(otfpushrange(o, " offset-plus (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-at f) (field-attr f 'at)) (define (field-offset f) (field-attr f 'offset)) ; returns #t if it's an array with each element having its own ; offset pointed to by elements of another array field (define (field-array-with-offsets f) (define v (assoc 'at (field-attrs f))) (define a (caddr v)) (>= (length a) 1)) (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 (field-enum f) (field-attr f 'enum)) (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 bits (λ (bit ename) (~a "(v->" (field-name f) array-index "&" ename ")?\" " ename "\":\"\""))) ", " #:before-first ", ")) "")) (define enum (field-enum f)) (define enum-verbs (or (and enum "%s") "")) (define enum-args (or (and enum (string-join (hash-map enum (λ (val ename) (~a "v->" (field-name f) array-index "==" ename "?\" " ename "\""))) ": " #:before-first ", " #:after-last ":\"\"")) "")) (define print-index (if basic-array (~a "f->print(f->aux, \"%*s%s[%d]: " verb bits-verbs enum-verbs "\\n\", indent, \"\", \"" (field-name f) "\", i, " (fmtarg (~a "v->" (field-name f) array-index)) bits-args enum-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-at f) (not cnt))) (define lst (flatten (list (if (type? t) (list (~a "f->print(f->aux, \"%*s%s: " verb bits-verbs enum-verbs "\\n\", indent, \"\", \"" (field-name f) "\", " (fmtarg (~a "v->" (field-name f) array-index)) bits-args enum-args ");") (if (field-context? f) (~a "o->" (field-name f) " = v->" (field-name f) ";") empty)) (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 optional) #:transparent #:methods gen:code [(define/generic super-gen-h gen-h) (define/generic super-gen-c gen-c) (define (gen-h c) (define valbits (filter-map (λ (f) (define bits (field-bits f)) (and bits (list (~a "// " (field-name f)) (hash-map bits (λ (bit ename) (~a ename " = 1<<" bit ",")))))) (cmplx-fields c))) (define valenums (filter-map (λ (f) (define enum (field-enum f)) (and enum (list (~a "// " (field-name f)) (hash-map enum (λ (val ename) (~a ename " = " val ",")))))) (cmplx-fields c))) (define values (append valbits valenums)) (define enums (if (empty? values) empty (list (~a "enum { // " (cmplx-name c)) (indent values) (~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-at f) (field-at (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-at (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])