Overview
| Comment: | Added support to show the [waitons] section on the Run Control tab. |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | descendants | both | v1.65 |
| Files: | files | file ages | folders |
| SHA1: |
f9a243a4c5849427f01c7a9948da14c3 |
| User & Date: | mrwellan on 2020-10-20 18:37:57 |
| Other Links: | branch diff | manifest | tags |
Context
|
2020-10-20
| ||
| 21:26 | Removed noisy print check-in: c1b62ae797 user: mrwellan tags: v1.65 | |
| 18:37 | Added support to show the [waitons] section on the Run Control tab. check-in: f9a243a4c5 user: mrwellan tags: v1.65 | |
|
2020-10-19
| ||
| 00:22 | Rearranged the target for chicken. check-in: c3c27bb923 user: matt tags: v1.65 | |
Changes
Modified tests.scm from [0094b671e6] to [994fb90053].
| ︙ | ︙ | |||
1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 |
;; (lambda (x)(equal? "node" (car x)))
;; (map string-split (tests:easy-dot test-records "plain"))))))
;; (map car (sort data (lambda (a b)
;; (> (string->number (caddr a))(string->number (caddr b)))))))
;; ))
(sort all-tests sort-fn1)))) ;; avoid dealing with deleted tests, look at the hash table
(define (tests:easy-dot test-records outtype)
(let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX"))))
(let ((all-testnames (hash-table-keys test-records))
(temp-port (open-output-file* fd)))
;; (format temp-port "This file is ~A.~%" temp-path)
(format temp-port "digraph tests {\n")
(format temp-port " size=4,8\n")
;; (format temp-port " splines=none\n")
(for-each
(lambda (testname)
(let* ((testrec (hash-table-ref test-records testname))
| > > > > > > > > > > > > > > > > > | > > | | 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 |
;; (lambda (x)(equal? "node" (car x)))
;; (map string-split (tests:easy-dot test-records "plain"))))))
;; (map car (sort data (lambda (a b)
;; (> (string->number (caddr a))(string->number (caddr b)))))))
;; ))
(sort all-tests sort-fn1)))) ;; avoid dealing with deleted tests, look at the hash table
;; look up all waitons that are related to test "testname"
;;
(define (tests:get-mt-waitons testname flatten)
(let* ((mt-waitons (configf:get-section *configdat* "waitons"))
(my-waitons (filter
(lambda (x)
(string-match (conc "^(" testname "|" testname"/.*)$") (car x)))
mt-waitons)))
(if flatten
(map (lambda (w)
(car (string-split w "/")))
(apply append (map (lambda (x)
(string-split (cadr x)))
my-waitons)))
my-waitons)))
;; NOT USED
(define (tests:easy-dot test-records outtype)
(let-values (((fd temp-path) (file-mkstemp (conc "/tmp/" (current-user-name) ".XXXXXX"))))
(let ((all-testnames (hash-table-keys test-records))
(temp-port (open-output-file* fd)))
;; (format temp-port "This file is ~A.~%" temp-path)
(format temp-port "digraph tests {\n")
(format temp-port " size=4,8\n")
;; (format temp-port " splines=none\n")
(for-each
(lambda (testname)
(let* ((testrec (hash-table-ref test-records testname))
(waitons (or (tests:testqueue-get-waitons testrec) '()))
(my-mt-waitons (tests:get-mt-waitons testname #t)))
;; (print "my-mt-waitons=" my-mt-waitons)
(for-each
(lambda (waiton)
(format temp-port (conc " " waiton " -> " testname " [splines=ortho]\n")))
(append waitons my-mt-waitons))))
all-testnames)
(format temp-port "}\n")
(close-output-port temp-port)
(with-input-from-pipe
(conc "env -i PATH=$PATH dot -T" outtype " < " temp-path)
(lambda ()
(let ((res (read-lines)))
|
| ︙ | ︙ | |||
1743 1744 1745 1746 1747 1748 1749 1750 |
(tal (cdr all-testnames))
(res (list "digraph tests {"
(conc " size=\"" (or sizex 11) "," (or sizey 11) "\";")
" ratio=0.95;"
)))
(let* ((testrec (hash-table-ref test-records hed))
(waitons (or (tests:testqueue-get-waitons testrec) '()))
(newres (append res
| > > | | < > | 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 |
(tal (cdr all-testnames))
(res (list "digraph tests {"
(conc " size=\"" (or sizex 11) "," (or sizey 11) "\";")
" ratio=0.95;"
)))
(let* ((testrec (hash-table-ref test-records hed))
(waitons (or (tests:testqueue-get-waitons testrec) '()))
(my-mt-waitons (tests:get-mt-waitons hed #t))
(all-waitons (delete-duplicates (append waitons my-mt-waitons)))
(newres (append res
(if (null? all-waitons)
(list (conc " \"" hed "\" [shape=box];"))
(map (lambda (waiton)
(conc " \"" waiton "\" -> \"" hed "\" [shape=box];"))
all-waitons)))))
(debug:print 0 *default-log-port* "For test "hed" got "all-waitons)
(if (null? tal)
(append newres (list "}"))
(loop (car tal)(cdr tal) newres)
))))))
;; (tests:run-dot (list "digraph tests {" "a -> b" "}") "plain")
|
| ︙ | ︙ |