329 lines
11 KiB
Scheme
329 lines
11 KiB
Scheme
(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 (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))))))))
|