Add VCD file parser
This commit is contained in:
Nikolay Puzanov
parent
b9bbb4cec4
commit
251120d54b
332
embddr/vcd.scm
Executable file
332
embddr/vcd.scm
Executable file
@ -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))))))))
|
||||
Loading…
x
Reference in New Issue
Block a user