1 files changed, 122 insertions, 0 deletions
diff --git a/scripts/synthesis-results.scm b/scripts/synthesis-results.scm
new file mode 100755
index 0000000..faf8919
--- /dev/null
+++ b/scripts/synthesis-results.scm
@@ -0,0 +1,122 @@
+#! /usr/bin/chicken-csi -s
+;; -*- mode: scheme -*-
+
+(import (chicken port)
+        (chicken process-context)
+        (chicken string)
+        (chicken irregex)
+        (chicken file)
+        args
+        matchable
+        srfi-193
+        ssax)
+
+(define options)
+(define operands)
+
+(define (check-opt b) (cdr (or (assoc b options) `(,b . #f))))
+
+(define opts
+	(list (args:make-option (v verbose) (optional: "LEVEL") "Debug level [default: 0]"
+	                        (set! arg (or arg "0")))
+        (args:make-option (k keys) (required: "KEY,KEY,...") "Keys to display [default: slice,ramfifo,delay]")
+        (args:make-option (o output) (required: "FILE") "Output file")
+        (args:make-option (s suppress) (required: "TYPE,TYPE,...") "Values to suppress from output [default: none]")
+        (args:make-option (x xml) #:none "Output raw XML from the synthesis tool")
+        (args:make-option (c csv) #:none "Output processed CSV")
+	      (args:make-option (V version) #:none "Display version"
+	                        (print "synthesise v0.1.0")
+	                        (exit))
+	      (args:make-option (h help) #:none "Display this text"
+	                        (usage))))
+
+(: description string)
+(define description
+  "synthesise: sends a verilog file to be synthesised and returns results as a CSV file.")
+
+(define (usage)
+	(with-output-to-port (current-error-port)
+	  (lambda ()
+      (print description)
+      (newline)
+	    (print "Usage: " (program-name) " [options...] [files...]")
+	    (newline)
+	    (print (args:usage opts))
+	    (print "Report bugs to git at yannherklotz dot com.")))
+  (exit 1))
+
+(define (map-names n)
+  (match n
+    ["XILINX_LUT_FLIP_FLOP_PAIRS_USED" "lut_flip_flop"]
+    ["XILINX_SLICE" "slice"]
+    ["XILINX_SLICE_REGISTERS" "regs"]
+    ["XILINX_SLICE_LUTS" "luts"]
+    ["XILINX_BLOCK_RAMFIFO" "ramfifo"]
+    ["XILINX_IOPIN" "iopin"]
+    ["XILINX_DSPS" "dsps"]
+    ["XILINX_POWER" "power"]
+    ["XILINX_DESIGN_DELAY" "delay"]
+    [_ n]))
+
+(define (csv:fmt-row l) (string-intersperse (map ->string l) ","))
+
+(define (csv:fmt-table-string l) (apply string-append (map (lambda (s) (string-append s "\n")) l)))
+
+(define (csv:fmt-table l) (apply string-append (map (lambda (s) (string-append s "\n"))
+                                                    (map csv:fmt-row l))))
+
+(define (xml-matcher xml)
+  (match xml
+    [('*TOP* _ ('document ('application ('section _ . r))))
+     (map (match-lambda
+            [('item ('@ ('value v) ('stringID s))) (list (map-names s) (string->number v))]) r)]))
+
+(define (parse-xml name file)
+  (with-input-from-file file
+    (lambda ()
+      (list name (xml-matcher (ssax:xml->sxml (current-input-port) '()))))))
+
+(define (to-csv-record b head results)
+  (let ((res (map (lambda (key)
+                    (cadr (assoc key (cadr results)))) head)))
+    (csv:fmt-row (if b res (cons (car results) res)))))
+
+(: path-to-name (string -> string))
+(define (path-to-name path)
+  (irregex-replace "^.*?([^/]+)_report\\.xml$" path 1))
+
+(define (convert-files files)
+  (map (lambda (f) (parse-xml (path-to-name f) f)) files))
+
+(: split-at-comma (string -> (list-of string)))
+(define (split-at-comma s) (string-split s ","))
+
+(: find-all-xml (string -> (list-of string)))
+(define (find-all-xml dir) (find-files dir #:test ".*\\.xml$"))
+
+(define (get-files-from-op operands)
+  (match operands
+    [(d) (cond [(directory-exists? d) (find-all-xml d)]
+               [else (list d)])]
+    [_ operands]))
+
+(define (with-output thk)
+  (if (check-opt 'output)
+      (with-output-to-file (check-opt 'output) thk)
+      (thk)))
+
+(define (main args)
+  (set!-values (options operands)
+	             (args:parse args opts))
+  (let ((head (split-at-comma (or (check-opt 'keys) "slice,ramfifo,delay")))
+        (suppress (split-at-comma (or (check-opt 'suppress) "none")))
+        (files (get-files-from-op operands)))
+    (let ((body (map (lambda (f) (to-csv-record (member "name" suppress) head f))
+                     (convert-files files)))
+          (header (csv:fmt-row (if (member "name" suppress) head (cons "name" head)))))
+    (with-output
+        (lambda ()
+          (display (csv:fmt-table-string
+                    (if (member "header" suppress) body (cons header body)))))))))
+
+(main (command-line-arguments))