1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
|
;; (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) '())))
(for-each
(lambda (waiton)
(format temp-port (conc " " waiton " -> " testname " [splines=ortho]\n")))
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)))
|
|
>
>
|
|
1631
1632
1633
1634
1635
1636
1637
1638
1639
1640
1641
1642
1643
1644
1645
1646
1647
1648
1649
1650
1651
|
;; (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)))
|
1664
1665
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
|
(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
(if (null? waitons)
(list (conc " \"" hed "\" [shape=box];"))
(map (lambda (waiton)
(conc " \"" waiton "\" -> \"" hed "\" [shape=box];"))
waitons)
))))
(if (null? tal)
(append newres (list "}"))
(loop (car tal)(cdr tal) newres)
))))))
;; (tests:run-dot (list "digraph tests {" "a -> b" "}") "plain")
|
>
>
|
|
<
>
|
1666
1667
1668
1669
1670
1671
1672
1673
1674
1675
1676
1677
1678
1679
1680
1681
1682
1683
1684
1685
1686
1687
1688
|
(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")
|