From 251120d54b811b4d5a6a68daa465b1788d231fe1 Mon Sep 17 00:00:00 2001
From: Nikolay Puzanov <np@embddr.com>
Date: Tue, 6 Dec 2022 15:05:36 +0300
Subject: [PATCH] Add VCD file parser

---
 embddr/vcd.scm | 332 +++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 332 insertions(+)
 create mode 100755 embddr/vcd.scm

diff --git a/embddr/vcd.scm b/embddr/vcd.scm
new file mode 100755
index 0000000..08e3802
--- /dev/null
+++ b/embddr/vcd.scm
@@ -0,0 +1,332 @@
+(define-module (embddr vcd))
+
+(import (srfi srfi-1)                   ; Lists
+        (srfi srfi-9)                   ; Records
+        (srfi srfi-11)                  ; Values
+        (srfi srfi-26)                  ; Cut
+        (srfi srfi-28)                  ; Simple format
+        (srfi srfi-34)                  ; Exceptions
+        (srfi srfi-69)                  ; Hash tables
+        (ice-9 textual-ports))
+
+(import
+ (ice-9 pretty-print)
+ (statprof))
+
+(import (embddr common))
+
+(export vcd-parse
+        (signal-scope . vcd-signal-scope)
+        (signal-name . vcd-signal-name)
+        (signal-type . vcd-signal-type)
+        (signal-size . vcd-signal-size)
+        (signal-get . vcd-signal-get)
+        vcd-binary->hex)
+
+;;;
+;;; VCD data structure
+;;;
+(define-record-type <vcd>
+  (vcd-new timescale timestamps signals)
+  vcd?
+  (timescale vcd-timescale)
+  (timestamps vcd-tstamps)
+  (signals vcd-signals))
+
+;;;
+;;; Signal representation structure
+;;;
+(define-record-type <signal>
+  (signal-new scope name type size value)
+  signal?
+  (scope signal-scope)
+  (name signal-name)
+  (type signal-type)
+  (size signal-size)
+  (value signal-get signal-set!))
+
+;;; Add sample to signal values list
+(define (signal-add! sig value)
+  (signal-set! sig (cons value (signal-get sig))))
+
+;;;
+;;; Parse timescale value (eg: 1ps, 100ns etc)
+;;; Returns value in ns
+;;;
+(define (parse-timescale ts)
+  (let ((dim-idx (string-skip ts char-numeric?)))
+    (if dim-idx
+        (let* ((n (string->number (substring ts 0 dim-idx)))
+               (unit (substring ts dim-idx))
+               (k (assoc unit '(("s" 1e9) ("ms" 1e6) ("us" 1e3) ("ns" 1) ("ps" 1e-3) (fs 1e-6)))))
+          (if k
+              (* n (cadr k))
+              (raise `(vcd-syntax-error
+                       ,(format "Unknown timescale unit '~a'" unit)))))
+        (raise `(vcd-syntax-error
+                 ,(format "Wrong timescale '~a'" ts))))))
+
+;;;
+;;; Parse and extend binary value
+;;;
+(define (parse-binary-value str width)
+  (let ((len (string-length str)))
+    (cond
+     ((zero? len)
+      (raise `(vcd-syntax-error "Empty binary value")))
+
+     ((> len width)
+      (raise `(vcd-syntax-error
+               ,(format "Binary value (~a) length > signal width (~a)" str width))))
+
+     ;; Extend shorter
+     ((< len width)
+      (string-append
+       (make-string
+        (- width len)
+        (let ((h (string-ref str 0)))
+          (if (char-numeric? h) #\0 h)))
+       str))
+
+     (else str))))
+
+;;;
+;;; Parse real value
+;;;
+(define (parse-real-value str unused) str)
+
+;;;
+;;; Get VCD tag as ($keyword ... $end) as words list without $end
+;;;
+(define* (vcd-get-command port)
+  (let get-cmd-rec ((wlist '()))
+    (let ((w (get-word port)))
+      (if (not w)
+          (if (null? wlist)
+              #f
+              (reverse wlist))
+          (if (null? wlist)
+              (if (or (equal? w "$comment")
+                      (equal? w "$date")
+                      (equal? w "$enddefinitions")
+                      (equal? w "$scope")
+                      (equal? w "$timescale")
+                      (equal? w "$upscope")
+                      (equal? w "$var")
+                      (equal? w "$version"))
+                  (get-cmd-rec `(,w))
+                  (raise `(vcd-syntax-error
+                           ,(format "Unknown declaration keyword '~a'" w))))
+              (if (equal? w "$end")
+                  (reverse wlist)
+                  (get-cmd-rec (cons w wlist))))))))
+
+;;;
+;;; Parse VCD header
+;;; Returns values of timescale and association list (tag . (<signal> ...))
+;;;
+(define (read-header port)
+  (let next-cmd ((timescale #f)
+                 (scope '())
+                 (tags+signals '()))
+    (let ((cmd (vcd-get-command port)))
+      (if (not cmd)
+          (if timescale
+              (values timescale tags+signals)
+              (raise `(vcd-syntax-error "Timescale is not defined")))
+          (let ((name (first cmd)))
+            (cond
+             ((string-ci= name "$timescale")
+              (next-cmd (parse-timescale (second cmd)) scope tags+signals))
+
+             ((string-ci= name "$scope")
+              (next-cmd timescale (cons (third cmd) scope) tags+signals))
+
+             ((string-ci= name "$var")
+              (let ((type (cond
+                           ((or (equal? "real" (second cmd))
+                                (equal? "realtime" (second cmd))) 'real)
+                           ((equal? "event" (second cmd)) 'event)
+                           (else 'bits)))
+                    (width (string->number (third cmd)))
+                    (tag (fourth cmd))
+                    (vname (string-concatenate
+                            (insert-between
+                             (cddddr cmd) " "))))
+                (next-cmd timescale scope
+                          (let ((tag+sig (assoc tag tags+signals))
+                                (sig (signal-new (reverse scope)
+                                                 vname type width '())))
+                            (if tag+sig
+                                (begin
+                                  (set-cdr! tag+sig (cons sig (cdr tag+sig)))
+                                  tags+signals)
+                                (cons (cons tag `(,sig)) tags+signals))))))
+
+             ((string-ci= "$upscope" (first cmd))
+              (next-cmd timescale (cdr scope) tags+signals))
+
+             ((string-ci= "$enddefinitions" (first cmd))
+              (if (not timescale)
+                  (raise '(vcd-syntax-error "Timescale is not defined"))
+                  (values timescale tags+signals)))
+
+             (else (next-cmd timescale scope tags+signals))))))))
+
+;;;
+;;; Read data block and return list of lists (time changes ..)
+;;;
+(define (read-data port)
+  (let read-rec ((samples '())
+                 (time #f)
+                 (changes '()))
+    (let ((line (get-line port)))
+      (if (eof-object? line)
+          (reverse
+           (if (and time (not (null? changes)))
+               (cons (cons time changes) samples)
+               samples))
+          (let ((line (string-trim-both line)))
+            (cond
+             ((or (string-null? line)
+                  (equal? (string-ref line 0) #\$))
+              (read-rec samples time changes))
+
+             ((equal? (string-ref line 0) #\#)
+              (read-rec
+               (if (and time (not (null? changes)))
+                   (cons (cons time changes) samples)
+                   samples)
+               (let ((time (string->number (substring line 1))))
+                 (if time
+                     time
+                     (raise `(vcd-syntsx-error "Bad time format '~a'" line))))
+               '()))
+
+             (else
+              (read-rec samples time (cons line changes)))))))))
+
+;;;
+;;; Parse VCD data block
+;;; Returns <vcd> record
+;;;
+(define (parse-data samples timescale tags+signals)
+  (let* ((samples-count (length samples))
+         (tags+signals-ht (alist->hash-table tags+signals)))
+
+    (for-each
+     (lambda (sample)
+       (let ((time (car sample)))
+         (for-each
+          (lambda (line)
+            (let ((c0 (string-ref line 0))
+                  (rest (substring line 1)))
+              ;; (display (format "-- c0:'~a' rest:'~a'\n" c0 rest))
+              (let-values
+                  (((parse-value tag value)
+                    (cond
+                     ;; Scalar value
+                     ((or (equal? c0 #\0)
+                          (equal? c0 #\1)
+                          (char-ci=? c0 #\x)
+                          (char-ci=? c0 #\z))
+                      (values parse-binary-value
+                              rest
+                              (string (char-downcase c0))))
+
+                     ;; Binary or real value
+                     ((or (char-ci=? c0 #\b)
+                          (char-ci=? c0 #\r))
+
+                      ;; Fast but unsafe
+                      (let ((val-idx (string-index rest #\space)))
+                        (if val-idx
+                            (let ((value (substring rest 0 val-idx))
+                                  (tag (substring rest (+ val-idx 1))))
+                              (values (if (char-ci=? c0 #\b)
+                                          parse-binary-value
+                                          parse-real-value)
+                                      tag
+                                      value))
+                            (raise `(vcd-syntax-error
+                                     ,(format "Bad value change string '~a'" line)))))
+
+                      ;; Slow but safety
+                      ;; (let ((ss (string-split-trim rest char-whitespace?)))
+                      ;;   (if (= (length ss) 2)
+                      ;;       (let ((value (first ss))
+                      ;;             (tag (second ss)))
+                      ;;         (values (if (char-ci=? c0 #\b)
+                      ;;                     parse-binary-value
+                      ;;                     parse-real-value)
+                      ;;                 tag
+                      ;;                 value))
+                      ;;       (raise `(vcd-syntax-error
+                      ;;                ,(format "Bad value change string '~a'" line)))))
+                      ))))
+
+                (let ((sigs (hash-table-ref/default tags+signals-ht tag #f)))
+                  (unless (null? sigs)
+                    (for-each
+                     (lambda (sig)
+                       (signal-add!
+                        sig
+                        (cons time (parse-value value (signal-size sig)))))
+                     sigs))))))
+          (cdr sample))))
+     samples)
+
+    (vcd-new timescale
+             (map car samples)
+             (let ((signals (fold (lambda (tag+sig out)
+                                    (append (cdr tag+sig) out))
+                                  '()  tags+signals))
+                   (last-time (car (last samples))))
+               (map (lambda (sig)
+                      (signal-set! sig (reverse (signal-get sig)))
+                      sig)
+                    signals)))))
+
+;;;
+;;; Parse whole VCD
+;;; Returns list of time stamps and list of lists (<signal> valuse ...)
+;;;
+(define (vcd-parse port)
+  (call-with-values
+      (lambda () (read-header port))
+    (cut parse-data
+         (read-data port)
+         <...>)))
+
+;;;
+;;; Convert 4-state binary string to hex
+;;;
+(define (vcd-binary->hex binstr)
+  (string-concatenate
+   (map
+    (lambda (quad)
+      (if (string-every char-numeric? quad)
+          (number->string
+           (string->number quad 2)
+           16)
+          (if (string-every (cut char-ci=? #\z <>) quad)
+              "z"
+              "x")))
+    (let split-by-quad ((str (string-reverse binstr))
+                        (quads '()))
+      (cond
+       ((string-null? str) quads)
+       ((<= (string-length str) 4)
+        (cons (string-append
+               (make-string
+                (- 4 (string-length str))
+                (let ((h (string-ref str 0)))
+                  (if (char-numeric? h) #\0 h)))
+               (string-reverse str))
+              quads))
+       (else
+        (split-by-quad
+         (string-drop str 4)
+         (cons
+          (string-reverse
+           (string-take str 4)) quads))))))))