np/hdl-unit-test-suite
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Compare commits

base: np:af29e1b7fa679c5e81d92e94f47b01391b44eb7b
Branches Tags
np:main
..
compare: np:8b4ae738a14c37c87c6498e1af11f70c47dde411
Branches Tags
np:main

No commits in common. "af29e1b7fa679c5e81d92e94f47b01391b44eb7b" and "8b4ae738a14c37c87c6498e1af11f70c47dde411" have entirely different histories.
af29e1b7fa ... 8b4ae738a1

1 changed files with 50 additions and 130 deletions
Show Stats Expand all files Collapse all files

180
utest.scm
View File

@ -177,42 +177,6 @@
(println (convert-log-item str colorize))))) (println (convert-log-item str colorize)))))
log-strings)) log-strings))
;;;
;;; Catch exception and continue with default value
;;;
(define-syntax guard
(syntax-rules ()
((_ default code...)
(with-exception-handler (lambda (e) default)
(lambda () code...)
#:unwind? #t))))
;;;
;;; Check path existence
;;; If path not exists throw exception
;;;
(define (check-path path)
(if (not (file-exists? path))
(raise-exception (format "Path ~a is not exists" path))
(let ((type (stat:type (stat path))))
(if (or (not (access? path R_OK))
(and (eq? type 'directory)
(not (access? path X_OK))))
(raise-exception (format "Path ~a is not readable" path))
#t))))
;;;
;;; Convert path to absolute path
;;;
(define* (path->absolute path #:optional (base ""))
(let ((path
(if (or (string-null? base)
(absolute-file-name? path))
path
(string-append base "/" path))))
(check-path path)
(canonicalize-path path)))
;;; ;;;
;;; Create file with simulation timeout watchdog ;;; Create file with simulation timeout watchdog
;;; ;;;
@ -238,7 +202,7 @@
(* " $finish;") (* " $finish;")
(* " end") (* " end")
(* "endmodule"))) (* "endmodule")))
(path->absolute filename))) (canonicalize-path filename)))
;;; ;;;
;;; Create dump module ;;; Create dump module
@ -257,31 +221,29 @@
(* " $dumpvars(0, ~a);" top) (* " $dumpvars(0, ~a);" top)
(* " end") (* " end")
(* "endmodule"))) (* "endmodule")))
(path->absolute filename))) (canonicalize-path filename)))
;;; ;;;
;;; Return directory list ;;; Return directory list
;;; ;;;
(define (list-dir path) (define (list-dir path)
(if (file-exists? path) (let ((dir (opendir path)))
(let ((dir (opendir path))) (let loop ((ls '()))
(let loop ((ls '())) (let ((item (readdir dir)))
(let ((item (readdir dir))) (if (eof-object? item)
(if (eof-object? item) (begin
(begin (closedir dir)
(closedir dir) ls)
ls) (if (or (string=? item ".")
(if (or (string=? item ".") (string=? item ".."))
(string=? item "..")) (loop ls)
(loop ls) (loop (cons (string-append path "/" item) ls))))))))
(loop (cons (string-append path "/" item) ls)))))))
'()))
;;; ;;;
;;; Recursive delete directory ;;; Recursive delete directory
;;; ;;;
(define (delete-recursive path) (define (delete-recursive path)
(let ((path (path->absolute path))) (let ((path (canonicalize-path path)))
(if (eq? 'directory (stat:type (stat path))) (if (eq? 'directory (stat:type (stat path)))
(begin (begin
(for-each delete-recursive (list-dir path)) (for-each delete-recursive (list-dir path))
@ -289,48 +251,42 @@
(delete-file path)))) (delete-file path))))
;;; ;;;
;;; Recursive find path items for which the function f returns true ;;; Convert path to absolute path
;;;
(define* (path->absolute path #:optional (base ""))
(canonicalize-path
(if (string-null? base)
path
(string-append base "/" path))))
;;;
;;; Find path items for which the function f returns true
;;; (fn fullpath type) : (-> (string symbol) boolean) ;;; (fn fullpath type) : (-> (string symbol) boolean)
;;; Returns empty list if files not found ;;; Returns empty list if files not found
;;; ;;;
(define* (find-paths-rec fn base #:optional (follow-symlink #f)) (define* (find-paths fn base #:optional (follow-symlink #f))
(let ((ls (list-dir base))) (let ((ls (list-dir base)))
(let ((files.dirs (let ((files.dirs
(fold (lambda (name f.d) (fold (lambda (name f.d)
;; There is a risk that some paths may have disappeared during recursive search. (let ((files (car f.d))
;; To avoid an error, we can catch the exception from the stat function (dirs (cdr f.d)))
(let* ((t (stat:type (stat name)))
;; (let ((t (guard #f (stat:type (stat name))))) (f (if (fn name t) (cons name files) files)))
;; (if t (if (or (eq? t 'directory)
;; (let* ((files (car f.d)) (and follow-symlink
;; (dirs (cdr f.d)) (eq? t symlink)))
;; (f (if (fn name t) (cons name files) files))) (cons f (cons name dirs))
;; (if (or (eq? t 'directory) (cons f dirs)))))
;; (and follow-symlink
;; (eq? t symlink)))
;; (cons f (cons name dirs))
;; (cons f dirs)))
;; f.d))
(let* ((files (car f.d))
(dirs (cdr f.d))
(t (stat:type (stat name)))
(f (if (fn name t) (cons name files) files)))
(if (or (eq? t 'directory)
(and follow-symlink
(eq? t symlink)))
(cons f (cons name dirs))
(cons f dirs))))
'(()) ls))) '(()) ls)))
(let ((files (car files.dirs)) (let ((files (car files.dirs))
(dirs (cdr files.dirs))) (dirs (cdr files.dirs)))
(fold (lambda (dir files) (fold (lambda (dir files)
(append files (find-paths-rec fn dir follow-symlink))) (append files (find-paths fn dir follow-symlink)))
files dirs))))) files dirs)))))
;;; ;;;
;;; Recursive find files with name matched a regular expression ;;; Find files with name matched a regular expression
;;; (find-files-rec-regexp rx base [follow-symlink #f]) -> (listof path?) ;;; (find-files-regexp rx base [follow-symlink #f]) -> (listof path?)
;;; rx : string? ;;; rx : string?
;;; base : string? ;;; base : string?
;;; follow-symlink : boolean? ;;; follow-symlink : boolean?
@ -338,40 +294,15 @@
;;; rx - regulat expression ;;; rx - regulat expression
;;; base - base directory for files search ;;; base - base directory for files search
;;; ;;;
(define* (find-files-rec-regexp rx base #:optional (follow-symlink #f)) (define* (find-files-regexp rx base #:optional (follow-symlink #f))
(if (eq? 'regular (stat:type (stat base))) (if (eq? 'regular (stat:type (stat base)))
(if (string-match rx (basename base)) (list base) '()) (if (string-match rx (basename base)) (list base) '())
(find-paths-rec (find-paths
(lambda (f t) (lambda (f t)
(and (eq? t 'regular) (and (eq? t 'regular)
(string-match rx (basename f)))) (string-match rx (basename f))))
base follow-symlink))) base follow-symlink)))
;;;
;;; Recursive find files in testbench base directory
;;;
(define* (utest/find-files-rec rx #:key (base "") (follow-symlink #f))
(find-files-rec-regexp
rx
(if (string-null? base)
(utest/base-path)
(format "~a/~a" (utest/base-path) base))
follow-symlink))
;;;
;;; Find files in testbench base directory
(define* (utest/find-files rx #:key (base "") (follow-symlink #f))
(let* ((base (path->absolute
(if (string-null? base)
(utest/base-path)
(format "~a/~a" (utest/base-path) base))))
(ls (list-dir base)))
(filter (lambda (f)
(and (not (string=? f "."))
(not (string=? f ".."))
(string-match rx f)))
ls)))
;;; ;;;
;;; Prepare argument list ;;; Prepare argument list
;;; #f -> '() ;;; #f -> '()
@ -441,11 +372,6 @@
(parameters '()) ; -P=X (parameters '()) ; -P=X
(other '())) (other '()))
(define (string-or-num-param x)
(if (number? x)
(format "~a" x)
(format "'\"~a\"'" x)))
(let ((opts (let ((opts
(cons (cons
iverilog-executable iverilog-executable
@ -468,11 +394,11 @@
(if (or (not top) (list? top)) (if (or (not top) (list? top))
(car x) (car x)
(format "~a.~a" top (car x))) (format "~a.~a" top (car x)))
(string-or-num-param (cadr x)))) (cadr x)))
parameters) parameters)
(map (lambda (x) (map (lambda (x)
(if (list? x) (if (list? x)
(format "-D~a=~a" (car x) (string-or-num-param (cadr x))) (format "-D~a=~a" (car x) (cadr x))
(format "-D~a" x))) (format "-D~a" x)))
defines) defines)
other other
@ -549,7 +475,7 @@
(vpipaths '()) (vpipaths '())
(warnings "all") (warnings "all")
(dumpformat 'fst) (dumpformat 'fst)
(timeout '(1 s))) (timeout '(1 ms)))
;; Get parameters ;; Get parameters
(let ((force-dump (utest/force-dump)) (let ((force-dump (utest/force-dump))
@ -564,11 +490,6 @@
(let ((sources (append (map (lambda (x) (path->absolute x base-path)) (let ((sources (append (map (lambda (x) (path->absolute x base-path))
(arg-to-list sources)) (arg-to-list sources))
(list timeout-module dump-module))) (list timeout-module dump-module)))
(defines (append defines
`((UTEST_BASE_DIR ,(format "'\"~a\"'" base-path))
(UTEST_WORK_DIR ,(format "'\"~a\"'" work-path)))))
(includes (map (lambda (x) (path->absolute x base-path)) (arg-to-list includes))) (includes (map (lambda (x) (path->absolute x base-path)) (arg-to-list includes)))
(modpaths (map (lambda (x) (path->absolute x base-path)) (arg-to-list modpaths))) (modpaths (map (lambda (x) (path->absolute x base-path)) (arg-to-list modpaths)))
(vpipaths (map (lambda (x) (path->absolute x base-path)) (arg-to-list vpipaths))) (vpipaths (map (lambda (x) (path->absolute x base-path)) (arg-to-list vpipaths)))
@ -618,7 +539,7 @@
(define (collect-test-procs files) (define (collect-test-procs files)
(fold (fold
(lambda (f procs) (lambda (f procs)
(let ((f (path->absolute f))) (let ((f (canonicalize-path f)))
(append (append
procs procs
(map (lambda (proc) (list proc (dirname f) (basename f))) (map (lambda (proc) (list proc (dirname f) (basename f)))
@ -635,7 +556,7 @@
(base (cadr test)) (base (cadr test))
(name (proc 'name)) (name (proc 'name))
(name (format "~a~a/~a" (name (format "~a~a/~a"
(let* ((pwd (string-append (path->absolute (getcwd)) "/")) (let* ((pwd (string-append (canonicalize-path (getcwd)) "/"))
(base-loc (base-loc
(if (string-prefix? pwd base) (if (string-prefix? pwd base)
(substring base (string-length pwd)) (substring base (string-length pwd))
@ -688,8 +609,7 @@
(work (mkdtemp (format "~a/~a~a-~a-~a-XXXXXX" (work (mkdtemp (format "~a/~a~a-~a-~a-XXXXXX"
base WORK_DIR_PREFIX base WORK_DIR_PREFIX
makefile-name makefile-name
(string-map (lambda (c) (if (char-whitespace? c) #\_ c)) (string-map (lambda (c) (if (char-whitespace? c) #\_ c)) name)
(string-downcase name))
(current-time))))) (current-time)))))
;; Execute test ;; Execute test
(let* ((p #f) (let* ((p #f)
@ -820,7 +740,7 @@
(define (delete-work-dirs base force) (define (delete-work-dirs base force)
(let ((work-dirs (let ((work-dirs
(if force (if force
(find-paths-rec (find-paths
(lambda (p t) (lambda (p t)
(and (eq? t 'directory) (and (eq? t 'directory)
(string-match (string-match
@ -831,14 +751,14 @@
(lambda (makefile work-dirs) (lambda (makefile work-dirs)
(append (append
work-dirs work-dirs
(find-paths-rec (find-paths
(lambda (p t) (lambda (p t)
(and (eq? t 'directory) (and (eq? t 'directory)
(string-match (string-match
(format "^~a~a.*-[0-9]{10}-.{6}$" WORK_DIR_PREFIX (basename makefile)) (format "^~a~a.*-[0-9]{10}-.{6}$" WORK_DIR_PREFIX (basename makefile))
(basename p)))) (basename p))))
(dirname makefile)))) (dirname makefile))))
'() (find-files-rec-regexp MAKEFILE_NAME_REGEXP base))))) '() (find-files-regexp MAKEFILE_NAME_REGEXP base)))))
(if (null? work-dirs) (if (null? work-dirs)
(printf "Working folders not found\n") (printf "Working folders not found\n")
(for-each (for-each
@ -921,7 +841,7 @@
(jobs (string->number (option-ref options 'jobs "0"))) (jobs (string->number (option-ref options 'jobs "0")))
(jobs (if (zero? jobs) (current-processor-count) jobs)) (jobs (if (zero? jobs) (current-processor-count) jobs))
(rest (option-ref options '() '())) (rest (option-ref options '() '()))
(path (path->absolute (if (null? rest) (getcwd) (car rest))))) (path (canonicalize-path (if (null? rest) (getcwd) (car rest)))))
(cond (cond
((option-ref options 'help #f) (print-help (car args))) ((option-ref options 'help #f) (print-help (car args)))
@ -940,7 +860,7 @@
(let ((makefiles (let ((makefiles
(if (eq? 'regular (stat:type (stat path))) (if (eq? 'regular (stat:type (stat path)))
(list path) (list path)
(find-files-rec-regexp MAKEFILE_NAME_REGEXP path)))) (find-files-regexp MAKEFILE_NAME_REGEXP path))))
(if (<= jobs 1) (if (<= jobs 1)
(execute-tests (collect-test-procs makefiles)) (execute-tests (collect-test-procs makefiles))