#!/usr/bin/env -S guile -e "(@@ (register-gen) main)" -s
!#

;; -*- geiser-scheme-implementation: guile -*-

;;; How to use module:
;; (add-to-load-path "./")
;; (import (register-gen))
;; (display (config-file->text-doc "./test.regs"))

(define-module (register-gen))

(export
 config-file->verilog
 config-file->c-header
 config-file->text-doc)

(add-to-load-path (dirname (current-filename)))

(import
 (srfi srfi-1)                          ; Lists
 (srfi srfi-9)                          ; Records
 (srfi srfi-11)                         ; let-values
 (srfi srfi-26)                         ; cut/cute
 (srfi srfi-28)                         ; Simple format
 (common)
 (optargs))

;;; Possible access mode list
(define MODES '(r w rw hs unused))

;;; Default access mode
(define DEFAULT-MODE 'rw)

;;; Count of indentation spaces
(define INDENT 2)

;;; Width of test field
(define TEXT_WIDTH 80)
(define MINIMUM_COL_WIDTH 4)

;;; Default module name suffix
(define MODULE_SUFFIX "_reg")

;;;
;;; Print to stderr
;;;
(define (warning . rest)
  (display "Warning: " (current-error-port))
  (display (apply format rest) (current-error-port))
  (newline (current-error-port)))

(define (error . rest)
  (display "Error: " (current-error-port))
  (display (apply format rest) (current-error-port))
  (newline (current-error-port))
  (exit EXIT_FAILURE))

;;;
;;; Register config structure
;;;
(define-record-type <config>
  (config module-name base
          address-width data-width
          byte-width byte-enable
          registers registered-selector)
  config?
  (module-name config-module-name)
  (base config-base)
  (address-width config-awidth)
  (data-width config-dwidth)
  (byte-width config-bwidth)
  (byte-enable config-ben)
  (registers config-regs)
  (registered-selector config-registered?))

;;; Get data bytres count
(define (config-bytes cfg)
  (/ (config-dwidth cfg)
     (config-bwidth cfg)))

;;; Get byte-selection address width
(define (config-bytes-awidth cfg)
  (clog2 (config-bytes cfg)))

;;;
;;; Register structure
;;;
(define-record-type <register>
  (register name info offset read-notify bits)
  register?
  (name register-name)
  (info register-info)
  (offset register-offset)
  (bits register-bits)
  (read-notify register-read-notify?))

;;;
;;; Bitfield structure
;;;
(define-record-type <bitfield>
  (bitfield name wname info lsb
            msb mode reset values)
  bitfield?
  (name bitfield-name)
  (wname bitfield-wname)
  (info bitfield-info)
  (lsb bitfield-lsb)
  (msb bitfield-msb)
  (mode bitfield-mode)
  (reset bitfield-reset)
  (values bitfield-values))

;;;
;;; Bitfield values structure
;;;
(define-record-type <bitfield-value>
  (bfvalue name value info)
  bfvalue?
  (name bfvalue-name)
  (value bfvalue-value)
  (info bfvalue-info))

;;; Return count of used bits in a register
(define (register-used-width reg)
  (let ((bits (register-bits reg)))
    (if (null? bits)
        0
        (+ 1 (fold max 0 (map bitfield-msb bits))))))

;;; Returns #t if register bitfield need storage (trigger)
(define (register-need-variable? reg)
  (any (lambda (bf)
         (member (bitfield-mode bf) '(w rw hs)))
       (register-bits reg)))

;;; Returns bitfield width
(define (bitfield-width bf)
  (- (bitfield-msb bf) (bitfield-lsb bf) -1))

;;; Check bitfield for crossing bytes boundary
(define (cross-bytes-boundry? msb lsb bwidth)
  (not (= (floor (/ msb bwidth))
          (floor (/ lsb bwidth)))))

;;;
;;; Useful functions
;;;

;;; Returns x or default if x is null or #f
(define (ifnull x default)
  (if (or (not x)
          (null? x))
      default
      x))

;;; Like assq but ignore non-list items
(define (assq* v l)
  (find (lambda (x) (and (list? x) (eq? v (car x)))) l))

;;; Like assq* but return all matches (in order)
(define (assq+ v l)
  (filter (lambda (x) (and (list? x) (eq? v (car x)))) l))

;;; assq* + cdr + default function
(define (assq*-cdr v l def)
  (let ((x (assq* v l)))
    (if (or (not x)
            (null? x))
        def
        (cdr x))))

;;; assq* + cadr + default function
(define (assq*-cadr v l def)
  (let ((x (assq* v l)))
    (if (or (not x)
            (null? x))
        def
        (cadr x))))

;;; assq* + cadr + default function
(define (assq*-cadr-f v l def-fn)
  (let ((x (assq* v l)))
    (if (or (not x)
            (null? x))
        (def-fn)
        (cadr x))))
;;;
;;; Print with indentationm
;;;   (-> [indent] format-string [parameters])
(define (->> . fmt)
  (cond
   ((null? fmt) #f)
   ((number? (car fmt))
    (let ((indent (car fmt))
          (rest (cdr fmt)))
      (when (not (null? rest))
        (display (list->string (make-list (* indent INDENT) #\space)))
        (display (apply format rest)))))
   (else
    (display (apply format fmt)))))

;;;
;;; Println with indentationm
;;;   (-> [indent] format-string [parameters])
;;;
(define (-> . fmt)
  (apply ->> fmt)
  (newline))

;;;
;;; ----------------------------------------------------------------------
;;; --------------------------- CONFIG PARSER ----------------------------
;;; ----------------------------------------------------------------------
;;;

;;;
;;; Parse bits list
;;;
(define (parse-bit-list bit-list reg-name dwidth default-mode)
  (let loop ((bit-list bit-list) (lsb 0) (bits '()))
    (if (null? bit-list)
        (if (null? bits)
            (error "No bitfield specified in register '~a'" reg-name)
            (reverse bits))
        (let ((bit-raw (cdr (car bit-list))))
          (let* ((blen (car bit-raw))
                 (msb (+ lsb blen -1))
                 (name (ifnull (find string? bit-raw) ""))
                 (mode (ifnull (find (lambda (x) (any (lambda (xx) (eq? x xx)) MODES)) bit-raw) default-mode))
                 (reset (assq*-cadr 'reset bit-raw 0))
                 (wname (if (eq? mode 'w) #f (cadr (ifnull (assq* 'write-name bit-raw) '(#f #f)))))
                 (info (assq*-cdr 'info bit-raw '("")))
                 (values
                  (map (lambda (info-lst)
                         (let ((value (car info-lst))
                               (vname (find string? info-lst))
                               (info (assq*-cadr 'info info-lst "")))
                           (if vname
                               (bfvalue vname value info)
                               (error "Bitfield value must have name (~a/~a)" reg-name name))))
                       (assq*-cdr 'values bit-raw '())))
                 (dup-value (find-duplicates (map bfvalue-name values) string<?)))
            (cond
             ;; Check duplicate name
             ((any (lambda (x) (string=? name (bitfield-name x))) bits)
              (error "Duplicate bitfield '~a' in register '~a'" name reg-name))
             ;; Check bit range
             ((or (<= blen 0) (>= msb dwidth))
              (error "Bitfield '~a' is out of range in register '~a'" name reg-name))
             ;; Check bit values
             (dup-value
              (error "Duplicate value '~a` in bitfield '~a', register '~a'" dup-value name reg-name))
             ;; All is OK
             (else
              (loop (cdr bit-list) (+ lsb blen)
                    (cons (bitfield name wname info lsb msb mode reset values) bits)))))))))

;;;
;;; Parse registers list
;;;
(define (parse-reg-list reg-list awidth dwidth bwidth offset)
  (let ((bytes (/ dwidth bwidth)))
    (let loop ((reg-list reg-list) (offset offset) (regs '()))
      (if (null? reg-list)
          (reverse regs)
          (let ((reg-raw (car reg-list)))
            (if (eq? (car reg-raw) 'offset)

                ;; Set offset
                (let ((offset (cadr reg-raw)))
                  (if (not (zero? (remainder offset bytes)))
                      (error "Offset ~a is not aligned to register width" offset)
                      (loop (cdr reg-list) offset regs)))

                ;; Add register
                (let ((name (ifnull (find string? reg-raw) ""))
                      (mode (ifnull (find (lambda (x) (any (lambda (xx) (eq? x xx)) MODES)) reg-raw) DEFAULT-MODE))
                      (info (cdr (ifnull (assq* 'info reg-raw) '(#f ""))))
                      (bit-list (assq+ 'bits reg-raw))
                      (read-notify (if (memq 'read-notify reg-raw) #t #f)))

                  (cond
                   ;; Check duplicate name
                   ((any (lambda (x) (string=? name (register-name x))) regs)
                    (error "Duplicate register '~a'" name))
                   ;; Check address depth
                   ((and awidth
                         (> offset (- (expt 2 awidth) (/ dwidth 4))))
                    (error "Register '~a' offset is out of address range" name))
                   ;; all is OK
                   (else
                    (let ((reg (register name info offset read-notify
                                         (parse-bit-list bit-list name dwidth mode))))
                      (loop (cdr reg-list) (+ offset bytes) (cons reg regs))))))))))))

;;;
;;; Parse reg config file
;;;
(define (parse-config-file file override-module-name override-base-address registered-selectors)
  (let ((config-list (with-input-from-file file read)))
    (let ((module-name
           (if override-module-name
               override-module-name
               (let ((w (assq* 'name config-list)))
                 (if w
                     (second w)
                     (string-append
                      (car (string-split (basename file) #\.)) MODULE_SUFFIX)))))
          (dwidth (assq*-cadr-f 'data-width config-list
                                (lambda () (warning "Data width will be set to 32 bit") 32)))
          (awidth (assq*-cadr-f 'address-width config-list
                                (lambda () (warning "Address width will be calculated automatically") #f)))
          (base
           (if override-base-address
               override-base-address
               (assq*-cadr-f 'base config-list
                             (lambda () (warning "Base address will be set to 0") 0))))
          (bwidth (assq*-cadr-f 'byte-width config-list (lambda () 8)))
          (ben (if (memq 'byte-enable config-list) #t #f))
          (reg-list (reverse
                     (fold (lambda (x l)
                             (if (and
                                  (list? x)
                                  (or (eq? (car x) 'reg)
                                      (eq? (car x) 'offset)))
                                 (cons x l)
                                 l))
                           '() config-list))))

      (when (not (integer? (/ dwidth bwidth)))
        (error "The data width is not a multiple of the byte width"))

      (let ((regs (parse-reg-list reg-list awidth dwidth bwidth 0)))
        (config
         module-name
         base
         (if awidth
             awidth
             ;; Calculate needed address width
             (clog2
              (+ (/ dwidth bwidth)
                 (fold max 0 (map register-offset regs)))))
         dwidth bwidth ben regs
         registered-selectors)))))

;;;
;;; ----------------------------------------------------------------------
;;; -------------------------- VERILOG BACKEND ---------------------------
;;; ----------------------------------------------------------------------
;;;

;;;
;;; Print module header and ports
;;;
(define (print-verilog-module-header cfg)
  (let ((regs (config-regs cfg))
        (awidth (config-awidth cfg))
        (dwidth (config-dwidth cfg))
        (bytes (config-bytes cfg)))

    (-> 0 "// This file is auto-generated. Do not edit")
    (->)
    (-> 0 "module ~a" (config-module-name cfg))
    (-> 1 "(input wire clock,")
    (-> 1 " input wire reset,")
    (->)
    (-> 1 " /* ---- Access bus ---- */")
    (-> 1 " /* verilator lint_off UNUSED */")
    (-> 1 " input wire [~a:0] ~a,"
        (- awidth 1)
        (if (config-registered? cfg) "i_la_addr" "i_addr"))
    (-> 1 " input wire [~a:0] i_data," (- dwidth 1))
    (-> 1 " output wire [~a:0] o_data," (- dwidth 1))
    (when (config-ben cfg)
      (-> 1 " input wire [~a:0] i_ben," (- bytes 1)))
    (-> 1 " input wire i_write,")
    (-> 1 " input wire i_read,")
    (-> 1 " /* verilator lint_on UNUSED */")

    (for-each
     (lambda (reg last)
       (let ((reg-name (register-name reg))
             (reg-bits (register-bits reg)))
         (->)
         (-> 1 " /* ---- '~a' ---- */" reg-name)

         (when (register-read-notify? reg)
           (-> 1 " output wire o_~a__rnotify~a"
               reg-name
               (if (and last
                        (or (null? reg-bits)
                            (every (cut eq? 'unused <>)
                                   (map bitfield-mode reg-bits))))
                   ");" ",")))

         (for-each
          (lambda (bit last)
            (let* ((name (bitfield-name bit))
                   (mode (bitfield-mode bit))
                   (lsb (bitfield-lsb bit))
                   (msb (bitfield-msb bit))
                   (msb0 (- msb lsb)))

              (cond
               ;; Read-only
               ((eq? mode 'r)
                (-> 1 " input wire ~ai_~a_~a~a"
                    (if (zero? msb0) "" (format "[~a:0] " msb0))
                    reg-name name
                    (if last ");" ",")))

               ;;  Write only
               ((eq? mode 'w)
                (-> 1 " output wire ~ao_~a_~a~a"
                    (if (zero? msb0) "" (format "[~a:0] " msb0))
                    reg-name name
                    (if last ");" ",")))

               ;; Read/write
               ((eq? mode 'rw)
                (-> 1 " input wire ~ai_~a_~a,"
                    (if (zero? msb0) "" (format "[~a:0] " msb0))
                    reg-name name)
                (let ((wname (bitfield-wname bit)))
                  (-> 1 " output wire ~ao_~a_~a~a"
                      (if (zero? msb0) "" (format "[~a:0] " msb0))
                      reg-name
                      (if wname wname name)
                      (if last ");" ","))))

               ;; Handshake output
               ((eq? mode 'hs)
                (-> 1 " output wire ~ao_~a_~a_hsreq,"
                    (if (zero? msb0) "" (format "[~a:0] " msb0))
                    reg-name name)
                (-> 1 " input wire ~ai_~a_~a_hsack,"
                    (if (zero? msb0) "" (format "[~a:0] " msb0))
                    reg-name name)
                (-> 1 " input wire ~ai_~a_~a~a"
                    (if (zero? msb0) "" (format "[~a:0] " msb0))
                    reg-name name
                    (if last ");" ","))))))
          reg-bits
          (reverse (cons last (cdr (map (lambda x #f) reg-bits)))))))
     regs
     ;; List of #f with last element of #t
     (reverse (cons #t (cdr (map (lambda x #f) regs)))))
    (->)))

;;;
;;; Print write address decoder
;;;
(define (print-verilog-address-selector cfg)
  (let ((regs (config-regs cfg))
        (awidth (config-awidth cfg))
        (dwidth (config-dwidth cfg))
        (bytes-awidth (config-bytes-awidth cfg))
        (registered (config-registered? cfg)))

    (-> 1 "/* ---- Address decoder ---- */")
    ;; Selector wires
    (for-each
     (cute -> 1 "~a ~a_select;" (if registered "reg" "wire") <>)
     (map register-name regs))
    (->)

    ;; Assign
    (let ((selectors (make-mux-selectors
                      (map register-offset regs))))
      (for-each
       (lambda (reg)
         (let* ((offset (register-offset reg))
                (name (register-name reg))
                (selector (cdr (assq offset selectors))))
           (if (every not selector)
               (-> 1 "assign ~a_select = 1'b1;" name)
               (begin
                 (if registered
                     (begin
                       (-> 1 "always @(posedge clock)")
                       (-> 2 "if (reset)")
                       (-> 3 "~a_select <= 1'b0;" name)
                       (-> 2 "else")
                       (-> 3 "~a_select <= " name))
                     (-> 1 "assign ~a_select =" name))

                 (let loop ((bits selector)
                            (n 0)
                            (need-and-sign #f))
                   (if (null? bits) #f
                       (begin
                         (let ((bit (car bits)))
                           (loop (cdr bits) (+ n 1)
                                 (if bit
                                     (begin
                                       (when need-and-sign (-> " &&"))
                                       (->> (if registered 4 2)
                                            "~a[~a] == 1'b~a"
                                            (if registered "i_la_addr" "i_addr")
                                            n bit)
                                       #t)
                                     need-and-sign))))))
                 (-> ";")))
           (->)))
       regs))))

;;;
;;; Print variables and write assigmnent for W/WR bitfield
;;;
(define (print-variables-wr bf reg-name byte-enable bwidth bytes)
  (let* ((wname (bitfield-wname bf))
         (name (if wname wname (bitfield-name bf)))
         (lsb (bitfield-lsb bf))
         (msb (bitfield-msb bf))
         (reset (bitfield-reset bf))
         (msb0 (- msb lsb))
         (bn (format "~a_~a" reg-name name)))

    ;; Declare variables
    (-> 1 "reg ~a~a;"
        (if (zero? msb0) "" (format "[~a:0] " msb0))
        bn)
    (-> 1 "assign o_~a = ~a;" bn bn)
    (->)

    ;; Assign variable
    (-> 1 "always @(posedge clock)")
    (-> 2 "if (reset)")
    (-> 3 "~a <= ~a'b0;" bn (+ 1 msb0))
    (-> 2 "else")

    (if byte-enable
        ;; If need byte-enabled write
        (begin
          (-> 3 "if (~a_select && i_write) begin" reg-name)
          (for-each
           (lambda (byte)
             (let ((byte-lsb (* byte bwidth))
                   (byte-msb (+ (* byte bwidth) (- bwidth 1))))
               (when (and (>= msb byte-lsb)
                          (<= lsb byte-msb))
                 (let* ((msb-s (if (> msb byte-msb) byte-msb msb))
                        (lsb-s (if (< lsb byte-lsb) byte-lsb lsb))
                        (msb-v (- msb-s lsb))
                        (lsb-v (- lsb-s lsb)))
                   (-> 4 "if (i_ben[~a]) ~a~a <= i_data[~a];"
                       byte
                       bn
                       (if (= msb lsb)
                           ""
                           (if (= msb-v lsb-v)
                               (format "[~a]" lsb-v)
                               (format "[~a:~a]" msb-v lsb-v)))
                       (if (= msb-s lsb-s)
                           (format "~a" lsb-s)
                           (format "~a:~a" msb-s lsb-s)))))))
           (iota bytes))
          (-> 3 "end"))
        ;; Write whole word
        (begin
          (-> 3 "if (~a_select && i_write)" reg-name)
          (-> 4 "~a <= i_data[~a];"
              bn
              (if (zero? msb0)
                  (format "~a" lsb)
                  (format "~a:~a" msb lsb)))))
    (->)))

;;;
;;; Print variables and write assigmnent for HS bitfield
;;;
(define (print-variables-hs bf reg-name byte-enable bwidth bytes)
  (let* ((name (bitfield-name bf))
         (lsb (bitfield-lsb bf))
         (msb (bitfield-msb bf))
         (msb0 (- msb lsb))
         (bv (format "~a_~a_hsreq" reg-name name))
         (br (format "i_~a_~a_hsack" reg-name name)))

    ;; Declare variables
    (-> 1 "reg ~a~a;" (if (zero? msb0) "" (format "[~a:0] " msb0)) bv)
    (-> 1 "assign o_~a = ~a;" bv bv)
    (->)

    ;; Assign variable
    (-> 1 "always @(posedge clock)")
    (-> 2 "if (reset)")
    (-> 3 "~a <= ~a'b0;" bv (+ 1 msb0))

    (if byte-enable
        ;; If need byte-enabled write
        (begin
          (-> 2 "else begin")
          (for-each
           (lambda (byte)
             (let ((byte-lsb (* byte bwidth))
                   (byte-msb (+ (* byte bwidth) (- bwidth 1))))
               (when (and (>= msb byte-lsb)
                          (<= lsb byte-msb))
                 (let* ((msb-s (if (> msb byte-msb) byte-msb msb))
                        (lsb-s (if (< lsb byte-lsb) byte-lsb lsb))
                        (msb-v (- msb-s lsb))
                        (lsb-v (- lsb-s lsb))
                        (vrange (if (= msb lsb)
                                    ""
                                    (if (= msb-v lsb-v)
                                        (format "[~a]" lsb-v)
                                        (format "[~a:~a]" msb-v lsb-v)))))
                   (-> 3 "if (~a_select && i_write && i_ben[~a]) ~a~a <= i_data[~a];"
                       reg-name byte
                       bv vrange
                       (if (= msb-s lsb-s)
                           (format "~a" lsb-s)
                           (format "~a:~a" msb-s lsb-s)))

                   (-> 3 "else ~a~a <= ~a~a & (~~~a~a);"
                       bv vrange
                       bv vrange
                       br vrange)))))
           (iota bytes))
          (-> 2 "end"))
        ;; Write whole word
        (begin
          (-> 2 "else")
          (-> 3 "if (~a_select && i_write)" reg-name)
          (-> 4 "~a <= i_data[~a];"
              bv
              (if (zero? msb0)
                  (format "~a" lsb)
                  (format "~a:~a" msb lsb)))
          (-> 3 "else")
          (-> 4 "~a <= ~a & (~~~a);" bv bv br)))
    (->)))

;;;
;;; Print register variables and write logic
;;;
(define (print-verilog-variables cfg)
  ;; Print registers variables
  (for-each
   (lambda (reg)
     (let ((reg-name (register-name reg))
           (need-variable (register-need-variable? reg))
           (read-notify (register-read-notify? reg)))
       (when (or need-variable read-notify)
         (->)
         (-> 1 "/* ---- '~a' ---- */" reg-name)

         (when need-variable
           (for-each
            (lambda (bit)
              (let* ((mode (bitfield-mode bit)))
                (cond
                 ;; Write-only and read/write bitfield
                 ((or (eq? mode 'w)
                      (eq? mode 'rw))
                  (print-variables-wr bit reg-name
                                      (config-ben cfg)
                                      (config-bwidth cfg)
                                      (config-bytes cfg)))

                 ;; Handshake bitfield
                 ((eq? mode 'hs)
                  (print-variables-hs bit reg-name
                                      (config-ben cfg)
                                      (config-bwidth cfg)
                                      (config-bytes cfg))))))
            (register-bits reg)))

         ;; Read-notify flag
         (when read-notify
           (-> 1 "assign o_~a__rnotify = ~a_select & i_read;" reg-name reg-name)
           (->)))))
   (config-regs cfg)))

;;;
;;; Print registers read multiplexer
;;;
(define (print-verilog-read-mux- cfg)
  (let ((regs (config-regs cfg))
        (awidth (config-awidth cfg))
        (dwidth (config-dwidth cfg))
        (bytes-awidth (config-bytes-awidth cfg)))

    (-> 1 "/* ---- Read multiplexer ---- */")
    (-> 1 "reg [~a:0] data_read;" (- dwidth 1))
    (-> 1 "assign o_data = data_read;")
    (->)

    ;; Mux
    (-> 1 "always @(*)")
    (-> 2 "case (i_addr[~a:~a])" (- awidth 1) bytes-awidth)
    (for-each
     (lambda (reg)
       (let* ((high-zero-bits (- dwidth (register-used-width reg)))
              (bits (if (zero? high-zero-bits)
                        (register-bits reg)
                        (append (register-bits reg)
                                `(,(bitfield "" #f ""
                                             (- dwidth high-zero-bits)
                                             (- dwidth 1)
                                             'unused 0 '())))))
              (reg-name (register-name reg)))

         ;; Reg address case
         (-> 3 "/* '~a' */" reg-name)
         (-> 3 "~a'b~a: begin"
             (- awidth bytes-awidth)
             (number->string-binary-slice
              (register-offset reg)
              (- awidth 1)
              bytes-awidth))

         (for-each
          (lambda (bf)
            (let ((bf-name (bitfield-name bf))
                  (mode (bitfield-mode bf))
                  (msb (bitfield-msb bf))
                  (lsb (bitfield-lsb bf))
                  (width (bitfield-width bf)))
              (let ((range (if (one? width)
                               (number->string msb)
                               (format "~a:~a" msb lsb))))
                (cond
                 ;; Unused bits
                 ((or (eq? mode 'unused)
                      (eq? mode 'w))
                  (-> 4 "data_read[~a] = ~a'b0;"
                      range width))

                 ;; Read and reaad/write bits
                 ((or (eq? mode 'r)
                      (eq? mode 'rw)
                      (eq? mode 'hs))
                  (-> 4 "data_read[~a] = i_~a_~a;"
                      range reg-name bf-name))))))
          bits)

         (-> 3 "end")
         (->)))
     regs)

    (-> 3 "default: data_read = ~a'b0;" dwidth)
    (-> 2 "endcase")))


(define (print-verilog-read-mux cfg)
  (let ((regs (config-regs cfg))
        (awidth (config-awidth cfg))
        (dwidth (config-dwidth cfg))
        (bytes-awidth (config-bytes-awidth cfg)))

    (-> 1 "/* ---- Read multiplexer ---- */")
    (for-each
     (cute -> 1 "reg [~a:0] data_~a;" (- dwidth 1) <>)
     (map register-name regs))
    (->)

    (-> 1 "assign o_data = ")
    (for-each
     (lambda (name n)
       (-> 2 "data_~a~a" name (if (zero? n) ";" " |")))
     (map register-name regs)
     (reverse (iota (length regs))))
    (->)

    (-> 1 "always @(*) begin")
    (for-each
     (cut -> 2 "data_~a = ~a'd0;" <> dwidth)
     (map register-name regs))
    (->)
    (for-each
     (lambda (reg)
       (let ((bits
               (filter (lambda (bf)
                         (let ((mode (bitfield-mode bf)))
                           (or (eq? mode 'r)
                               (eq? mode 'rw)
                               (eq? mode 'hs))))
                       (register-bits reg)))
             (reg-name (register-name reg)))

         (when (not (null? bits))
           (-> 2 "if (~a_select) begin" reg-name)
           (for-each
            (lambda (bf)
              (let ((bf-name (bitfield-name bf))
                    (msb (bitfield-msb bf))
                    (lsb (bitfield-lsb bf))
                    (width (bitfield-width bf)))
                (let ((range (if (one? width)
                                 (number->string msb)
                                 (format "~a:~a" msb lsb))))
                  (-> 3 "data_~a[~a] = i_~a_~a;"
                      reg-name range reg-name bf-name))))
            bits)
           (-> 2 "end")
           (->))))
     regs)
    (-> 1 "end")
    (->)))

;;;
;;; Print module footer
;;;
(define (print-verilog-module-footer cfg)
  (-> 0 "endmodule // ~a" (config-module-name cfg)))

;;;
;;; Convert config to verilog module
;;;
(define (config->verilog cfg)
  (with-output-to-string
    (lambda ()
      (print-verilog-module-header cfg)
      (print-verilog-address-selector cfg)
      (print-verilog-variables cfg)
      (print-verilog-read-mux cfg)
      (print-verilog-module-footer cfg))))

;;;
;;; ----------------------------------------------------------------------
;;; ------------------------- TEXT DOC BACKEND ---------------------------
;;; ----------------------------------------------------------------------
;;;

;;; Mode -> Name of mode
(define mode-names
  '((r "RO") (w "WO") (rw "RW") (hs "HS") (unused "unused")))

;;; String alignment with spaces
(define (string-align width align text)
  (let ((l (string-length text)))
    (if (>= l width)
        text
        (cond
         ((eq? align 'left)
          (string-append text (make-string (- width l) #\space)))
         ((eq? align 'right)
          (string-append (make-string (- width l) #\space) text))
         (else
          (let* ((al (round (/ (- width l) 2)))
                 (ar (- (- width l) al)))
            (string-append (make-string al #\space)
                           text
                           (make-string ar #\space))))))))

;;; Wrap string by words boundary
;;; Return list of strings with length less of equal 'width'
(define (string-word-wrap width str)
  (let ((make-sentence
         (lambda (words)
           (fold (lambda (word sent)
                   (if (string-null? sent)
                       word
                       (string-append sent " " word)))
                 "" words)))
        (words (string-split str #\space)))

    (let loop ((words-left '())
               (words-right words))
      (if (null? words-right)
          (list (make-sentence (reverse words-left)))
          (let* ((word (car words-right))
                 (left-width (string-length
                              (make-sentence
                               (cons word words-left)))))
            (cond
             ;; Crack word
             ((and (> left-width width)
                   (null? words-left))
              (cons (substring word 0 width)
                    (string-word-wrap
                     width
                     (make-sentence
                      (cons (substring word width)
                            (cdr words-right))))))

             ;; Split
             ((> left-width width)
              (cons (make-sentence (reverse words-left))
                    (string-word-wrap
                     width
                     (make-sentence words-right))))

             ;; Next word
             (else
              (loop (cons word words-left)
                    (cdr words-right)))))))))

;;;
;;; Make text table as list of strings
;;;
(define* (make-text-table header
                          header-align
                          body
                          body-align
                          word-wrap
                          max-width
                          minimum-col-width
                          #:key (paragraph-indent-width 1))

  ;; Word wrap each column in row
  (define (row-word-wrap widths wraps row)
    (map (lambda (width wrap col)
           (if wrap
               (fold (lambda (cell ret)
                       (append ret (string-word-wrap
                                    (- width paragraph-indent-width)
                                    cell)))
                     '() col)
               col))
         widths wraps row))

  ;; Make columns lengths equal
  (define (normalize-columns-in-row row)
    (let ((col-length (apply max (map length row))))
      (map (lambda (col)
             (let ((l (length col)))
               (if (< l col-length)
                   (append col (make-list (- col-length l) ""))
                   col)))
           row)))

  ;; Align columns width
  (define (align-columns width-lst wrap-lst table-width minimum-width)
    (let ((var-count (apply + (map (lambda (wrap) (if wrap 1 0)) wrap-lst))))
      (if (zero? var-count)
          (values width-lst wrap-lst)
          (let* ((w-fixed (apply + (map (lambda (w wrap) (if wrap 0 w))
                                        width-lst wrap-lst)))
                 (col-w-var (floor (/ (- table-width w-fixed) var-count)))
                 (col-w-var (if (< col-w-var minimum-width) minimum-width col-w-var)))
            (if (any (lambda (w wrap) (and wrap (<= w col-w-var))) width-lst wrap-lst)
                (let-values
                    (((width-lst wrap-lst)
                      (unzip2
                       (map (lambda (w.wrap)
                              (if (and (cadr w.wrap)
                                       (<= (car w.wrap) col-w-var))
                                  `(,(car w.wrap) #f)
                                  w.wrap))
                            (zip width-lst wrap-lst)))))
                  (align-columns width-lst wrap-lst table-width minimum-width))
                (values
                 (map (lambda (w wrap) (if wrap col-w-var w)) width-lst wrap-lst)
                 wrap-lst))))))

  ;; Convert row data to text table lines
  (define (row->string-list widths align row-list)
    (map (lambda (row n)
           (apply string-append
                  (cons "|"
                        (fold-right
                         (lambda (cell wrap w a ret)
                           (let ((text-width
                                  (if (and wrap (> n 0))
                                      (- w paragraph-indent-width)
                                      w)))
                             (cons* " "
                                    (make-string (- w text-width) #\space)
                                    (string-align text-width a cell)
                                    " |" ret)))
                         '()
                         row
                         word-wrap
                         widths
                         align))))
         row-list
         (iota (length row-list))))

  ;; Check integrity
  (let ((col-count (length header)))
    (when (not
           (every (lambda (x) (= col-count (length x)))
                  (cons* header-align body-align word-wrap body)))
      (error "in function make-text-table: wrong length of arguments")))

  (let ((table-text-width (- max-width (+ (* (length header) 3) 1)))
        ;; Calculate column widths
        (widths0
         (map (cut apply max <>)
              (transpose
               (map (lambda (row)
                      (map (lambda (col wrap)
                             (+
                              (apply max (map string-length col))
                              (if (and wrap (> (length col) 1))
                                  paragraph-indent-width 0)))
                           row word-wrap))
                    (cons (map list header) body))))))
    ;; Align columns
    (let-values
        (((widths wraps)
          (align-columns widths0 word-wrap table-text-width minimum-col-width)))

      (let (;; Word wrap header
            (header
             (transpose
              (normalize-columns-in-row
               (row-word-wrap widths wraps (map list header)))))

            ;; Word wrap body
            (body
             (map (lambda (row)
                    (transpose
                     (normalize-columns-in-row
                      (row-word-wrap widths wraps row))))
                  body))

            ;; Make separator
            (separator
             (fold (lambda (w n ret)
                     (string-append
                      ret
                      (make-string (+ w 2) #\-)
                      (if (zero? n) "|" "+")))
                   "|"
                   widths
                   (reverse (iota (length widths))))))

        ;; Make table lines
        (append
         (row->string-list widths header-align header)
         `(,separator)
         (apply append
                (map (cut row->string-list widths body-align <>) body)))))))

;;; Make table from register data
;;; Each row is a list of columns list
;;; Columns is a list of row cells (strings)
(define (register->table reg dwidth)
  (map (lambda (bf)
         (let ((name (bitfield-name bf))
               (wname (bitfield-wname bf))
               (msb (bitfield-msb bf))
               (lsb (bitfield-lsb bf))
               (mode (bitfield-mode bf))
               (info (bitfield-info bf))
               (reset (bitfield-reset bf))
               (unused (eq? (bitfield-mode bf) 'unused)))

           (list
            ;; Column 'Bits'
            `(,(if (= msb lsb) (number->string lsb) (format "~a:~a" msb lsb)))

            ;; Column 'Name'
            (cons
             (if unused "-" (string-upcase name))
             (if wname `(,(string-upcase wname)) '()))

            ;; Column 'Mode'
            (cons
             (if unused ""
                 (if wname
                     (second (assq 'r mode-names))
                     (second (assq mode mode-names))))
             (if wname `(,(second (assq 'w mode-names))) '()))

            ;; Column 'Reset'
            `(,(if unused ""
                   (cond
                    ((= reset 0) "0")
                    ((= reset 1) "1")
                    (else (format "0x~a" (number->string reset 16))))))

            ;; Column 'Info'
            info)))
       (sort (register-bits reg)
             (lambda (a b)
               (> (bitfield-lsb a)
                  (bitfield-lsb b))))))

;;;
;;; Print register description
;;;
(define (print-register-table reg awidth dwidth)
  (let ((name (register-name reg))
        (offset (register-offset reg))
        (info (register-info reg))
        (bits (register-bits reg)))

    ;; Print header name
    (let* ((header (format "~a Register (0x~a)"
                           (string-upcase name)
                           (number->string-hex
                            offset
                            (ceiling (/ awidth 4)))))
           (hline (string-map (lambda (x) #\-) header)))
      (-> header)
      (-> hline))

    ;; Print description
    (when (not (null? info))
      (->)
      ;; (-> "  Description:")
      (for-each (cut -> "  ~a" <>)
                (fold (lambda (s ret)
                        (append ret (string-word-wrap (- TEXT_WIDTH 2) s)))
                      '() info)))
    (->)

    ;; Print bitfields table
    (for-each
     (cut -> "  ~a" <>)
     (make-text-table '("Bits" "Name" "Mode" "Reset" "Description")
                      '(center center center center center)
                      (register->table reg dwidth)
                      '(right left left left left)
                      '(#f #f #f #f #t)
                      (- TEXT_WIDTH 2)
                      MINIMUM_COL_WIDTH))))

;;;
;;; Print register address map
;;;
(define (print-register-map-table cfg)
  (let ((awidth (config-awidth cfg))
        (dwidth (config-dwidth cfg))
        (regs (sort (config-regs cfg)
                    (lambda (a b)
                      (< (register-offset a)
                         (register-offset b))))))

    ;; Print header
    (let* ((header (format "Register map of ~a (base: 0x~a)"
                           (string-upcase (config-module-name cfg))
                           (number->string (config-base cfg) 16)))
           (hline (string-map (lambda (x) #\=) header)))
      (-> header)
      (-> hline)
      (->))

    ;; Make table body
    (let ((body
           (map (lambda (reg)
                  `((,(format "0x~a"
                              (number->string-hex
                               (register-offset reg)
                               (ceiling (/ awidth 4)))))
                    (,(string-upcase (register-name reg)))
                    (,(let ((info (register-info reg)))
                        (if (null? info) "" (car info))))))
                regs)))

      ;; Print table
      (for-each
       (cut -> "  ~a" <>)
       (make-text-table '("Offset" "Name" "Description")
                        '(center center center)
                        body
                        '(left left left)
                        '(#f #f #t)
                        (- TEXT_WIDTH 2)
                        MINIMUM_COL_WIDTH)))))

;;;
;;; Convert config to text document
;;;
(define (config->text-doc cfg)
  (with-output-to-string
    (lambda ()
      (print-register-map-table cfg)
      (newline)
      (let ((awidth (config-awidth cfg))
            (dwidth (config-dwidth cfg))
            (regs (sort (config-regs cfg)
                        (lambda (a b)
                          (< (register-offset a)
                             (register-offset b))))))
        (for-each
         (lambda (reg)
           (newline)
           (print-register-table reg awidth dwidth)
           (newline))
         regs)))))

;;;
;;; ----------------------------------------------------------------------
;;; ------------------------- C-HEADER BACKEND ---------------------------
;;; ----------------------------------------------------------------------
;;;

(define (config->c-header cfg)
  (with-output-to-string
    (lambda ()
      (let ((reg-prefix (string-upcase (config-module-name cfg)))
            (dwidth (config-dwidth cfg))
            (awidth (config-awidth cfg))
            (regs (config-regs cfg)))
        (-> "#ifndef _~a_H_" reg-prefix)
        (-> "#define _~a_H_" reg-prefix)
        (->)
        (-> "#define ~a_BASE 0x~a"
            reg-prefix
            (number->string (config-base cfg) 16))
        (->)

        (for-each
         (lambda (reg)
           (let ((reg-name (string-upcase (register-name reg))))
             (-> "/* -- Register '~a' -- */" reg-name)

             ;; Print register
             (-> "#define ~a_~a (*(volatile uint~a_t*)(~a_BASE + 0x~a))"
                 reg-prefix reg-name dwidth reg-prefix
                 (number->string-hex (register-offset reg)
                                     (ceiling (/ awidth 4))))
             (for-each
              (lambda (bf)
                (let ((bf-name (string-upcase (bitfield-name bf)))
                      (msb (bitfield-msb bf))
                      (lsb (bitfield-lsb bf))
                      (values (bitfield-values bf)))
                  (if (= msb lsb)
                      (-> "#define ~a_~a_~a (1 << ~a)"
                          reg-prefix reg-name bf-name msb)
                      (begin
                        (let ((mask (- (expt 2 (+ msb 1))
                                       (expt 2 lsb))))
                          (-> "#define ~a_~a_~a__MASK 0x~a"
                              reg-prefix reg-name bf-name
                              (number->string-hex mask (/ dwidth 4)))
                          (-> "#define ~a_~a_~a__SHIFT ~a"
                              reg-prefix reg-name bf-name lsb)
                          (for-each
                           (lambda (value)
                             (-> "#define ~a_~a_~a_~a 0x~a"
                                 reg-prefix reg-name bf-name
                                 (string-upcase (bfvalue-name value))
                                 (number->string
                                  (logand mask (ash (bfvalue-value value) lsb))
                                  16)))
                           values))))))
              (filter (lambda (bf)
                        (not (eq? 'unused (bitfield-mode bf))))
                      (register-bits reg)))

             (->)))
         regs)
        (-> "#endif // _~a_H_" reg-prefix)))))

;;;
;;; ----------------------------------------------------------------------
;;; ---------------------------- ENTRY POINT------------------------------
;;; ----------------------------------------------------------------------
;;;

(define (print-help app-name)
  (with-output-to-port (current-error-port)
    (lambda ()
      (-> "Usage: ~a [OPTION]... <FILE>" app-name)
      (-> "Make CPU/perepheral IO registers map. FILE - is a register description file.")
      (-> "By default tool prints source code of Verilog module.")
      (-> "")
      (-> "Options:")
      (-> "  -m, --module NAME    Set module name and registers prefix in C-header.")
      (-> "  -t, --text           Print text documentation.")
      (-> "  -c, --header         Print C-header.")
      (-> "  -b, --base NUM       Registers base address.")
      (-> "  -r, --registered     Make registered selectors.")
      (-> "  -h, --help           Print this message and exit")
      (-> "")
      (-> "Source code and issue tracker: <https://github.com/punzik/>"))))

;;; Convert arbitrary radix string in C-format to number
(define (string-c-radix->number str)
  (if (and str (string? str))
      (let ((str (string-trim-both str)))
        (cond
         ((string-every #\0 str) 0)
         ((string-prefix? "0x" str)
          (string->number (substring str 2) 16))
         ((string-prefix? "0b" str)
          (string->number (substring str 2) 2))
         ((string-prefix? "0" str)
          (string->number (substring str 1) 8))
         (else
          (string->number str 10))))
      #f))

;;;
;;; Exported function
;;;
(define* (config-file->verilog file #:key (module-name #f) (registered #f))
  (config->verilog
   (parse-config-file file module-name #f registered)))

(define* (config-file->c-header file #:key (module-name #f) (base #f))
  (config->c-header
   (parse-config-file file module-name base #f)))

(define* (config-file->text-doc file #:key (module-name #f) (base #f))
  (config->text-doc
   (parse-config-file file module-name base #f)))

;;;
;;; Main
;;;
(define (main args)
  (debug-disable 'backtrace)
  (let-values
      (((opts rest err)
        (parse-opts (cdr args)
                    '(("module" #\m) required)
                    '(("text" #\t) none)
                    '(("header" #\c) none)
                    '(("base" #\b) required)
                    '(("registered" #\r) none)
                    '(("help" #\h) none))))

    (if err
        (begin
          (error "Unknown option\n")
          (print-help (car args))
          (exit -1))

        (let ((opt-module (option-get opts "module"))
              (opt-text (option-get opts "text"))
              (opt-header (option-get opts "header"))
              (opt-base (option-get opts "base"))
              (opt-registered (option-get opts "registered"))
              (opt-help (option-get opts "help"))
              (opt-rest rest))

          (cond
           (opt-help
            (print-help (car args)))

           ((null? opt-rest)
            (print-help (car args))
            (error "No input files"))

           (else
            (let ((cfg (parse-config-file (car opt-rest)
                                          opt-module
                                          (string-c-radix->number opt-base)
                                          opt-registered)))
              (cond
               (opt-text
                (display (config->text-doc cfg)))
               (opt-header
                (display (config->c-header cfg)))
               (else
                (display (config->verilog cfg)))))))))))