shithub: fnt

Info  •  Files  •  Log  •  Branches

sprinkle contracts over

--- a/otf.rkt

+++ b/otf.rkt

@@ -3,24 +3,35 @@

 (require (for-syntax racket/format))

 (require (for-syntax syntax/parse))

+(require (for-syntax racket/contract))

+(require racket/contract)

 (require racket/generic)

-(define types '())

-(define cmplxs '())

+(define types '()) ; base types set

+(define cmplxs '()) ; complex types set

-(define (indent lst)

+(define size-in-bits/c

+  (make-contract #:name 'size-in-bits/c #:first-order (λ (x) (member x '(8 16 24 32 40 48 64)))))

+

+(define/contract (indent lst)

+  (-> (listof string?) (listof string?))

   (map (λ (str) (string-append "\t" str)) lst))

-(define (c-typedef? s)

+(define/contract (c-typedef? s)

+  (-> string? boolean?)

   (string-prefix? s "typedef"))

-(define (format f)

+(define/contract (format f)

+  (-> procedure? string?)

   (define-values (a b) (partition c-typedef? (flatten (map f cmplxs))))

   (define ps (list "/* this file is generated. do not modify. */\n" a b (map f types) ""))

   (string-join (flatten ps) "\n"))

-(define-generics code (gen-h code) (gen-c code) (c-type code))

+(define-generics code

+                 (gen-h code) ; generates code for the C header

+                 (gen-c code) ; generates code for the C source file

+                 (c-type code)) ; type name to be used in C

 (define-struct type (name bits c parse)

   #:transparent

@@ -32,7 +43,8 @@

    (define (c-type t)

      (type-c t))])

-(define (type-size t)

+(define/contract (type-size t)

+  (-> type? positive?)

   (/ (type-bits t) 8))

 (define-struct field (type name unused)

@@ -53,7 +65,7 @@

            (~a "\tgoto err;")

            (~a "}")))])

-(struct fieldarr field (count)

+(define-struct (fieldarr field) (count)

   #:transparent

   #:methods gen:code

   [(define/generic super-c-type c-type)

@@ -95,21 +107,24 @@

    (define (c-type c)

      (cmplx-name c))])

-(define-for-syntax (autoparse bits ctype)

-  (λ (b [index 0])

-    (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 "]" tail))

-    (~a (if (<= bits 32) cast "") "(" (f index bits) ")")))

+(begin-for-syntax

+  (define/contract (autoparse bits ctype)

+    (-> positive? symbol? (listof string?))

+    (λ (b [index 0])

+      (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 "]" tail))

+      (~a (if (<= bits 32) cast "") "(" (f index bits) ")"))))

 (define-syntax (mktype stx)

   (syntax-parse stx

     [(_ typ:id bits:nat c:id) #'(mktype typ bits c #'(autoparse bits c))]

-    [(_ typ:id bits:nat c:id parse:expr)

+    [(_ typ:id bits c:id parse:expr)

+     #:declare bits (expr/c #'size-in-bits/c #:name "size in bits")

      #'(begin

-         (define typ (make-type `typ bits `typ parse))

+         (define typ (make-type `typ bits.c `typ parse))

          (set! types (append types (list typ))))]))

 (define-syntax (mkcmplx stx)