;; This is a total rewrite of OTF parser generator logic, from Racket to sl(1)

(defmacro (defstruct name . fields)
  "Defines a structure type with a specific name and fields."
  (let* {[first (car fields)]
         [doc (and (string? first) first)]
         [fields (or (and doc (cdr fields)) fields)]
         [num-fields (length fields)]
         [fields-car (map (λ (f) (if (cons? f) (car f) f)) fields)]
         [is? (symbol (string name "?"))]
         [make (symbol (string "make-" name))]
         [undefined (gensym)]}
   `(begin
      (def (,is? s)
        (and [vector? s]
             [eq? (aref s 0) ',name]
             [= (length s) ,(1+ num-fields)]))
      (when ,doc
        (symbol-set-doc ',name ,doc))
      (def (,make ,@fields)
        (vector ',name ,@fields-car))
      ,@(map-int (λ (i) [let* {[fld (list-ref fields-car i)]
                               [fun (symbol (string name "-" fld))]}
                          `(def (,fun s (v ',undefined))
                             (assert (,is? s))
                             (if (eq? v ',undefined)
                                 (aref s ,[1+ i])
                                 (aset! s ,[1+ i] v)))])
                 num-fields))))

(doc-for (defstruct name doc . fields))

(defstruct type
  "OTF type."
  name bit-size c-type c-fmt (parse nil))

(defstruct c-fmt
  "C printf-like formatting value.
Verb is a C format string (\"%d\", for example).  The optional args is
a function that accepts one argument, a C variable name as a string,
and returns the C expressions that are to be formatted according to
verb value."
  verb
  (args identity))

(defmacro (mktype name bit-size c-type c-fmt (parse nil))
  "Define a basic OTF type."
  (unless (and (>= bit-size 8) (= (mod0 bit-size 8) 0))
    (throw 'invalid-bit-size bit-size))
  `(begin
     (if (has? otf-types ',name)
         (throw 'duplicate-type-name ',name))
         (put! otf-types
               ',name
               (make-type ',name ,bit-size ',c-type ,c-fmt ,parse))))

(def otf-types
  "Valid basic OTF types."
  (table))

(def (c-fmt-int bits (signed nil))
  "Return a c-fmt for printing a signed or unsigned integer of a specific bit width."
  (make-c-fmt (string #\% #\" "PRI" [if signed #\d #\u] bits #\")))

(def c-fmt-string
  "C nul-terminated string formatter."
  (make-c-fmt "%s"))

;; Basic OTF types.
(mktype uint8 8 u8int [c-fmt-int 8])
(mktype int8 8 s8int [c-fmt-int 8 :signed])
(mktype uint16 16 u16int [c-fmt-int 16])
(mktype int16 16 s16int [c-fmt-int 16 :signed])
(mktype uint24 24 u32int [c-fmt-int 32])
(mktype uint32 32 u32int [c-fmt-int 32])
(mktype int32 32 s32int [c-fmt-int 32 :signed])
(mktype UFWORD 16 u16int [c-fmt-int 16])
(mktype FWORD 16 s16int [c-fmt-int 16 :signed])
(mktype Offset16 16 u16int [c-fmt-int 16])
(mktype Offset24 24 u32int [c-fmt-int 32])
(mktype Offset32 32 u32int [c-fmt-int 32])
(mktype String 8 char c-fmt-string)
(mktype String-UTF16 16 char c-fmt-string)
(mktype Tag 32 u32int [make-c-fmt "%c%c%c%c" (λ (v) (string v">>24, "v">>16, "v">>8, "v">>0"))])

(def (assert-type name)
  "Throw an error if not a valid basic OTF type."
  (or (has? otf-types name)
      (error "invalid type: " name)))

(def (assert-types names)
  (and (every assert-type names) names))

(def (type-index? type)
  "Return T if the basic OTF type is allowed to be used for indexing."
  (assert-type type)
  (member type (assert-types '(uint16 uint32))))

(def (type-offset? type)
  "Return T if the basic OTF type defines an offset within the file or section."
  (assert-type type)
  (member type (assert-types '(Offset16 Offset24 Offset32))))

(def (type-number? type)
  "Return T if the basic OTF type is a number."
  (assert-type type)
  (member type (assert-types '(uint8 int8 uint16 int16 uint24 uint32 int32
                               Version16Dot16 Offset16 Offset24 Offset32))))

(def (type-comparable? type)
  "Return T if two values of the basic OTF can be compared."
  (assert-type type)
  (member type (assert-types '(uint8 int8 uint16 int16 uint24 uint32 int32
                               Version16Dot16))))