Compare commits
No commits in common. "af29e1b7fa679c5e81d92e94f47b01391b44eb7b" and "8b4ae738a14c37c87c6498e1af11f70c47dde411" have entirely different histories.
af29e1b7fa
...
8b4ae738a1
150
utest.scm
150
utest.scm
@ -177,42 +177,6 @@
|
||||
(println (convert-log-item str colorize)))))
|
||||
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
|
||||
;;;
|
||||
@ -238,7 +202,7 @@
|
||||
(* " $finish;")
|
||||
(* " end")
|
||||
(* "endmodule")))
|
||||
(path->absolute filename)))
|
||||
(canonicalize-path filename)))
|
||||
|
||||
;;;
|
||||
;;; Create dump module
|
||||
@ -257,13 +221,12 @@
|
||||
(* " $dumpvars(0, ~a);" top)
|
||||
(* " end")
|
||||
(* "endmodule")))
|
||||
(path->absolute filename)))
|
||||
(canonicalize-path filename)))
|
||||
|
||||
;;;
|
||||
;;; Return directory list
|
||||
;;;
|
||||
(define (list-dir path)
|
||||
(if (file-exists? path)
|
||||
(let ((dir (opendir path)))
|
||||
(let loop ((ls '()))
|
||||
(let ((item (readdir dir)))
|
||||
@ -274,14 +237,13 @@
|
||||
(if (or (string=? item ".")
|
||||
(string=? item ".."))
|
||||
(loop ls)
|
||||
(loop (cons (string-append path "/" item) ls)))))))
|
||||
'()))
|
||||
(loop (cons (string-append path "/" item) ls))))))))
|
||||
|
||||
;;;
|
||||
;;; Recursive delete directory
|
||||
;;;
|
||||
(define (delete-recursive path)
|
||||
(let ((path (path->absolute path)))
|
||||
(let ((path (canonicalize-path path)))
|
||||
(if (eq? 'directory (stat:type (stat path)))
|
||||
(begin
|
||||
(for-each delete-recursive (list-dir path))
|
||||
@ -289,48 +251,42 @@
|
||||
(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)
|
||||
;;; 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 ((files.dirs
|
||||
(fold (lambda (name f.d)
|
||||
;; There is a risk that some paths may have disappeared during recursive search.
|
||||
;; To avoid an error, we can catch the exception from the stat function
|
||||
|
||||
;; (let ((t (guard #f (stat:type (stat name)))))
|
||||
;; (if t
|
||||
;; (let* ((files (car f.d))
|
||||
;; (dirs (cdr f.d))
|
||||
;; (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)))
|
||||
;; f.d))
|
||||
|
||||
(let* ((files (car f.d))
|
||||
(dirs (cdr f.d))
|
||||
(t (stat:type (stat name)))
|
||||
(let ((files (car f.d))
|
||||
(dirs (cdr f.d)))
|
||||
(let* ((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))))
|
||||
(cons f dirs)))))
|
||||
'(()) ls)))
|
||||
(let ((files (car files.dirs))
|
||||
(dirs (cdr files.dirs)))
|
||||
(fold (lambda (dir files)
|
||||
(append files (find-paths-rec fn dir follow-symlink)))
|
||||
(append files (find-paths fn dir follow-symlink)))
|
||||
files dirs)))))
|
||||
|
||||
;;;
|
||||
;;; Recursive find files with name matched a regular expression
|
||||
;;; (find-files-rec-regexp rx base [follow-symlink #f]) -> (listof path?)
|
||||
;;; Find files with name matched a regular expression
|
||||
;;; (find-files-regexp rx base [follow-symlink #f]) -> (listof path?)
|
||||
;;; rx : string?
|
||||
;;; base : string?
|
||||
;;; follow-symlink : boolean?
|
||||
@ -338,40 +294,15 @@
|
||||
;;; rx - regulat expression
|
||||
;;; 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 (string-match rx (basename base)) (list base) '())
|
||||
(find-paths-rec
|
||||
(find-paths
|
||||
(lambda (f t)
|
||||
(and (eq? t 'regular)
|
||||
(string-match rx (basename f))))
|
||||
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
|
||||
;;; #f -> '()
|
||||
@ -441,11 +372,6 @@
|
||||
(parameters '()) ; -P=X
|
||||
(other '()))
|
||||
|
||||
(define (string-or-num-param x)
|
||||
(if (number? x)
|
||||
(format "~a" x)
|
||||
(format "'\"~a\"'" x)))
|
||||
|
||||
(let ((opts
|
||||
(cons
|
||||
iverilog-executable
|
||||
@ -468,11 +394,11 @@
|
||||
(if (or (not top) (list? top))
|
||||
(car x)
|
||||
(format "~a.~a" top (car x)))
|
||||
(string-or-num-param (cadr x))))
|
||||
(cadr x)))
|
||||
parameters)
|
||||
(map (lambda (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)))
|
||||
defines)
|
||||
other
|
||||
@ -549,7 +475,7 @@
|
||||
(vpipaths '())
|
||||
(warnings "all")
|
||||
(dumpformat 'fst)
|
||||
(timeout '(1 s)))
|
||||
(timeout '(1 ms)))
|
||||
|
||||
;; Get parameters
|
||||
(let ((force-dump (utest/force-dump))
|
||||
@ -564,11 +490,6 @@
|
||||
(let ((sources (append (map (lambda (x) (path->absolute x base-path))
|
||||
(arg-to-list sources))
|
||||
(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)))
|
||||
(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)))
|
||||
@ -618,7 +539,7 @@
|
||||
(define (collect-test-procs files)
|
||||
(fold
|
||||
(lambda (f procs)
|
||||
(let ((f (path->absolute f)))
|
||||
(let ((f (canonicalize-path f)))
|
||||
(append
|
||||
procs
|
||||
(map (lambda (proc) (list proc (dirname f) (basename f)))
|
||||
@ -635,7 +556,7 @@
|
||||
(base (cadr test))
|
||||
(name (proc 'name))
|
||||
(name (format "~a~a/~a"
|
||||
(let* ((pwd (string-append (path->absolute (getcwd)) "/"))
|
||||
(let* ((pwd (string-append (canonicalize-path (getcwd)) "/"))
|
||||
(base-loc
|
||||
(if (string-prefix? pwd base)
|
||||
(substring base (string-length pwd))
|
||||
@ -688,8 +609,7 @@
|
||||
(work (mkdtemp (format "~a/~a~a-~a-~a-XXXXXX"
|
||||
base WORK_DIR_PREFIX
|
||||
makefile-name
|
||||
(string-map (lambda (c) (if (char-whitespace? c) #\_ c))
|
||||
(string-downcase name))
|
||||
(string-map (lambda (c) (if (char-whitespace? c) #\_ c)) name)
|
||||
(current-time)))))
|
||||
;; Execute test
|
||||
(let* ((p #f)
|
||||
@ -820,7 +740,7 @@
|
||||
(define (delete-work-dirs base force)
|
||||
(let ((work-dirs
|
||||
(if force
|
||||
(find-paths-rec
|
||||
(find-paths
|
||||
(lambda (p t)
|
||||
(and (eq? t 'directory)
|
||||
(string-match
|
||||
@ -831,14 +751,14 @@
|
||||
(lambda (makefile work-dirs)
|
||||
(append
|
||||
work-dirs
|
||||
(find-paths-rec
|
||||
(find-paths
|
||||
(lambda (p t)
|
||||
(and (eq? t 'directory)
|
||||
(string-match
|
||||
(format "^~a~a.*-[0-9]{10}-.{6}$" WORK_DIR_PREFIX (basename makefile))
|
||||
(basename p))))
|
||||
(dirname makefile))))
|
||||
'() (find-files-rec-regexp MAKEFILE_NAME_REGEXP base)))))
|
||||
'() (find-files-regexp MAKEFILE_NAME_REGEXP base)))))
|
||||
(if (null? work-dirs)
|
||||
(printf "Working folders not found\n")
|
||||
(for-each
|
||||
@ -921,7 +841,7 @@
|
||||
(jobs (string->number (option-ref options 'jobs "0")))
|
||||
(jobs (if (zero? jobs) (current-processor-count) jobs))
|
||||
(rest (option-ref options '() '()))
|
||||
(path (path->absolute (if (null? rest) (getcwd) (car rest)))))
|
||||
(path (canonicalize-path (if (null? rest) (getcwd) (car rest)))))
|
||||
|
||||
(cond
|
||||
((option-ref options 'help #f) (print-help (car args)))
|
||||
@ -940,7 +860,7 @@
|
||||
(let ((makefiles
|
||||
(if (eq? 'regular (stat:type (stat path)))
|
||||
(list path)
|
||||
(find-files-rec-regexp MAKEFILE_NAME_REGEXP path))))
|
||||
(find-files-regexp MAKEFILE_NAME_REGEXP path))))
|
||||
|
||||
(if (<= jobs 1)
|
||||
(execute-tests (collect-test-procs makefiles))
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user