Overview
| Comment: | ceaned up dfs.scm a bit |
|---|---|
| Downloads: | Tarball | ZIP archive | SQL archive |
| Timelines: | family | ancestors | debug_chained_waiton | v1.60_defunct |
| Files: | files | file ages | folders |
| SHA1: |
a482e0ffbd7f2e60f09b6149b603ace7 |
| User & Date: | bjbarcla on 2016-04-18 18:47:11 |
| Other Links: | branch diff | manifest | tags |
Context
|
2016-04-18
| ||
| 18:47 | ceaned up dfs.scm a bit Closed-Leaf check-in: a482e0ffbd user: bjbarcla tags: debug_chained_waiton, v1.60_defunct | |
| 15:41 | adding my changes to runs.scm -- note: not in a completely runnable state check-in: 9ff8cae0bf user: bjbarcla tags: debug_chained_waiton, v1.60_defunct | |
Changes
Modified dfs.scm from [d2739ff496] to [7f464d5d1a].
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 |
(use extras)
(use data-structures)
(use srfi-1)
(use regex)
(define (tests:get-test-property test-registry test property)
(let loop ((rem-test-registry test-registry) (res #f))
(if (null? rem-test-registry)
res
(let* ((this-test (car rem-test-registry))
(this-testname (car this-test))
(this-testrec (cdr this-test)))
(if (eq? this-testname test)
(alist-ref property this-testrec)
(loop (cdr rem-test-registry) res))))))
(define (tests:get-test-waitons test-registry test)
(tests:get-test-property test-registry test 'waitons))
(define (tests:get-test-list test-registry)
(map car test-registry))
(define (alist-push alist key val)
(let ((current (alist-ref key alist)))
(if current
(alist-update key (cons val current) alist)
(cons (list key val) alist))))
| > > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 |
(use extras)
(use data-structures)
(use srfi-1)
(use srfi-13)
(use regex)
(define (tests:get-test-property test-registry test property)
(let loop ((rem-test-registry test-registry) (res #f))
(if (null? rem-test-registry)
res
(let* ((this-test (car rem-test-registry))
(this-testname (car this-test))
(this-testrec (cdr this-test)))
(if (eq? this-testname test)
(alist-ref property this-testrec)
(loop (cdr rem-test-registry) res))))))
(define (tests:get-test-waitons test-registry test)
(tests:get-test-property test-registry test 'waitons))
(define (tests:get-test-items test-registry test)
(or (tests:get-test-property test-registry test 'items) '()))
(define (tests:get-test-list test-registry)
(map car test-registry))
(define (alist-push alist key val)
(let ((current (alist-ref key alist)))
(if current
(alist-update key (cons val current) alist)
(cons (list key val) alist))))
(define (test:get-adjacency-list test-registry)
(let loop ((rem-tests (tests:get-test-list test-registry)) (res '()))
(if (null? rem-tests)
res
(let* ((test (car rem-tests))
(rest-rem-tests (cdr rem-tests))
(waitons
(or
|
| ︙ | ︙ | |||
51 52 53 54 55 56 57 |
(define (add-item-to-items-list item items)
(cond
((eq? item '%)
(list '%))
| | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > < | | | < > | | < < | < < < < < | > | | < | | | | > > > > > | > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 |
(define (add-item-to-items-list item items)
(cond
((eq? item '%)
(list '%))
((member '% items)
(list '%))
((member item items)
items)
(else
(cons item items))))
(define (append-items-lists l1 l2)
(let loop ((rem-l1 l1) (res l2))
(if (null? rem-l1)
res
(let* ((hed-rem-l1 (car rem-l1))
(tal-rem-l1 (cdr rem-l1))
(new-res (add-item-to-items-list hed-rem-l1 res)))
(loop tal-rem-l1 new-res)))))
(define (sort-any inlist)
(sort inlist (lambda (x y) (string<? (->string x) (->string y)))))
(define (condense-itemlist itemlist test test-registry)
(let* ((test-items (tests:get-test-items test-registry test))
(sorted-test-items (sort-any test-items))
(sorted-itemlist (sort-any itemlist))
(res
(cond
((member '% itemlist ) '(%))
((equal? sorted-itemlist sorted-test-items) '(%))
(else
(sort-any itemlist)))))
;;(print "condense-itemlist test-items="sorted-test-items" itemlist="sorted-itemlist" res="res " [equal?="(equal? sorted-test-items sorted-itemlist)"]")
res))
; TODO : warning if itempatt matches no items in test in test registry
(define (condense-testpatt-alist-dummy alist test-registry) alist)
(define (condense-testpatt-alist alist test-registry)
(let loop ((rest-alist alist) (res '()))
(if (null? rest-alist)
res
(let* ((hed-alist (car rest-alist))
(tal-alist (cdr rest-alist))
(testname (car hed-alist))
(incoming-items (cdr hed-alist))
(existing-item-list (alist-ref testname res))
(new-items-list
(condense-itemlist
(if existing-item-list
(append-items-lists incoming-items existing-item-list)
incoming-items)
testname
test-registry))
(new-res (alist-update testname new-items-list res)))
(loop tal-alist new-res)))))
; TODO : warning if itempatt matches no items in test in test registry
(define (testpatt:alist->string testpatt-alist test-registry)
(string-join
(let loop ((rem-alist testpatt-alist) (res '()))
(if (null? rem-alist)
res
(let* ((hed-alist (car rem-alist))
(tal-alist (cdr rem-alist))
(testname (car hed-alist))
(item-patts (cdr hed-alist))
(test-patts
(map
(lambda (item)
(conc (->string testname) "/" (->string item)))
item-patts))
(this-res (string-join test-patts ","))
(new-res (cons this-res res)))
;;(print "bb: test-patts="test-patts" this-res="this-res" res="res" new-res="new-res)
(loop tal-alist new-res))))
","))
(define (testpatt:string->alist testpatt test-registry)
(if (string? testpatt)
(let ((patts (string-split testpatt ",")))
(if (null? patts) ;;; no pattern(s) means no match
#f
(let loop ((rest-patts patts) (res '()))
;; (print "loop: patt: " patt ", tal " tal)
(if (null? rest-patts)
(condense-testpatt-alist res test-registry)
(let* ((hed-patt (car rest-patts))
(tal-rest-patts (cdr rest-patts))
(patt-parts (string-match (regexp "^([^\\/]*)(\\/(.*)|)$") hed-patt))
(test (string->symbol (cadr patt-parts)))
(item-patt-raw (cadddr patt-parts))
(item-patt
(if item-patt-raw
(string->symbol item-patt-raw)
'%))
(existing-item-patts (or (alist-ref test res) '()))
(new-item-patts (add-item-to-items-list item-patt existing-item-patts))
(new-res (alist-update test new-item-patts res)))
;(print "BB->: test="test" item-patt-raw="item-patt-raw" item-patt="item-patt" existing-item-patts="existing-item-patts" new-item-patts="new-item-patts)
(loop tal-rest-patts new-res))))))))
(define (traverse node adjacency-list path)
;(print "node="node" path="path)
(let ((children (alist-ref node adjacency-list)))
(cond
((not children) (list (cons node path)))
(else
(apply append
(map
(lambda (child)
(traverse child adjacency-list (cons node path)))
children))))))
(define (get-waiton-items parent-test parent-item-patterns waiton-test test-registry)
(let* ((parent-item->waiton-item (lambda (x) x)) ;; super simplified vs. megatest, should use itemmap property
(waiton-test-items (or (tests:get-test-property test-registry waiton-test 'items) '(%)))
)
(let loop ((rest-parent-item-patterns parent-item-patterns) (res '()))
(if (null? rest-parent-item-patterns)
res
(let* ((hed-parent-item (car rest-parent-item-patterns))
(tal-parent-items (cdr rest-parent-item-patterns))
(newres (add-item-to-items-list (parent-item->waiton-item hed-parent-item) res)))
(loop tal-parent-items newres))))))
;; TODO: only do this with itemwait set true, not always
(define (push-itempatt-down-path waiton-path seed-items test-registry )
(let loop ((rest-path waiton-path) (waiton-items seed-items) (res '()) )
(if (null? rest-path)
res
(let* ((hed-test (car rest-path))
(tal-path (cdr rest-path))
(waiton-test (car rest-path))
(waiton-items (get-waiton-items hed-test waiton-items waiton-test test-registry))
(new-res (cons (cons waiton-test waiton-items) res)))
(loop tal-path waiton-items new-res)))))
(define (sort-testpatt-alist-topologically testpatt-alist toposorted-testlist)
(let loop ((rem-testlist toposorted-testlist) (res '()))
(if (null? rem-testlist)
res ;; TODO - handle if alist has testsnot in toposort-list
(let* ((hed-test (car rem-testlist))
(tal-testlist (cdr rem-testlist))
(next-res (cons hed-test (alist-ref hed-test testpatt-alist)))
(new-res (cons next-res res)))
;;(print "bb stat - hed-test="hed-test" next-res="next-res)
(loop tal-testlist new-res)))))
(define (get-elaborated-testpatt-alist waiton-paths seed-testpatt-alist test-registry toposorted-testlist)
(let ((raw-res
(let loop ((rest-waiton-paths waiton-paths) (res '()))
(if (null? rest-waiton-paths)
res
(let* ((hed-path (car rest-waiton-paths))
(tal-paths (cdr rest-waiton-paths))
(test (car hed-path))
(items (alist-ref test seed-testpatt-alist))
(new-res (cons (push-itempatt-down-path hed-path items test-registry) res))
)
(loop tal-paths new-res))))))
(sort-testpatt-alist-topologically (condense-testpatt-alist (apply append raw-res) test-registry) toposorted-testlist)))
(define (get-elaborated-testpatt seed-testpatt test-registry)
(let* ((adjacency-list (test:get-adjacency-list test-registry))
(toposorted-testlist (topological-sort adjacency-list eq?))
(seed-testpatt-alist (testpatt:string->alist seed-testpatt test-registry))
(seed-tests (map car seed-testpatt-alist))
(waiton-paths
(map reverse
(apply append
(map
(lambda (test)
(traverse test adjacency-list '())) seed-tests))))
(final-testpatt-alist
(get-elaborated-testpatt-alist
waiton-paths
seed-testpatt-alist
test-registry
toposorted-testlist))
(final-testpatt-string (testpatt:alist->string final-testpatt-alist test-registry)))
final-testpatt-string))
;; (set! test-registry2
;; (cons
;; (cons 'ALL-TESTS (list (cons 'waitons (tests:get-test-list test-registry))))
;; test-registry))
(define test-registry
'(
(aa . ( (items . ( i1 i2 i3 )) ))
(a . ( (items . ( i1 i2 i3 )) ))
(b . ( (items . ( i1 i2 i3 ))
(waitons . (a) ) ) )
(c . ( (items . ( i1 i2 i3 ))
(waitons . (a) ) ) )
(f . ( (items . ( i1 i2 i3 ))
(waitons . (a) ) ) )
(d . ( (items . ( i1 i2 i3 ))
(waitons . (b c) ) ) )
(g . ( (items . ( i1 i2 i3 ))
(waitons . (b) ) ) )
(e . ( (items . ( i1 i2 i3 ))
(waitons . (d) ) ) )
(h . ( (items . ( i1 i2 i3 ))
(waitons . (d) ) ) )
))
(define seed-testpatt "a/i1,a/i3,d,aa/%")
(define elaborated-testpatt (get-elaborated-testpatt seed-testpatt test-registry))
(print "test-registry: ")
(pretty-print test-registry)
(print "\nseed-testpatt = "seed-testpatt)
(print "\nelaborated-testpatt = "elaborated-testpatt)
|