Index: megatest-version.scm ================================================================== --- megatest-version.scm +++ megatest-version.scm @@ -1,7 +1,7 @@ ;; Always use two digit decimal ;; 1.01, 1.02...1.10,1.11 ... 1.99,2.00.. (declare (unit megatest-version)) -(define megatest-version 1.5512) +(define megatest-version 1.5513) Index: mt.scm ================================================================== --- mt.scm +++ mt.scm @@ -85,10 +85,30 @@ (define (mt:get-prereqs-not-met run-id waitons ref-item-path #!key (mode 'normal)) (db:get-prereqs-not-met run-id waitons ref-item-path mode: mode)) (define (mt:get-run-stats) (cdb:remote-run db:get-run-stats #f)) + +(define (mt:discard-blocked-tests run-id failed-test tests test-records) + (if (null? tests) + tests + (begin + (debug:print-info 1 "Discarding tests from " tests " that are waiting on " failed-test) + (let loop ((testn (car tests)) + (remt (cdr tests)) + (res '())) + (let ((waitons (vector-ref (hash-table-ref/default test-records testn (vector #f #f '())) 2))) + ;; (print "mt:discard-blocked-tests run-id: " run-id " failed-test: " failed-test " testn: " testn " with waitons: " waitons) + (if (null? remt) + (let ((new-res (reverse res))) + ;; (print " new-res: " new-res) + new-res) + (loop (car remt) + (cdr remt) + (if (member failed-test waitons) + res + (cons testn res))))))))) ;;====================================================================== ;; T R I G G E R S ;;====================================================================== Index: runs.scm ================================================================== --- runs.scm +++ runs.scm @@ -367,11 +367,11 @@ '() reg))) (define runs:nothing-left-in-queue-count 0) -(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry) +(define (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records) (let* ((loop-list (list hed tal reg reruns)) (prereqs-not-met (mt:get-prereqs-not-met run-id waitons item-path mode: testmode)) (fails (runs:calc-fails prereqs-not-met)) (non-completed (runs:calc-not-completed prereqs-not-met))) (debug:print-info 4 "START OF INNER COND #2 " @@ -450,18 +450,21 @@ (if (eq? (hash-table-ref/default test-registry prereq 'justfine) 'CANNOTRUN) (set! give-up #t))) prereqstrs) (if (and give-up (not (and (null? tal)(null? reg)))) - (begin - (debug:print 1 "WARNING: test " hed " has no discarded prerequisites, removing it from the queue") - (list (runs:queue-next-hed tal reg reglen regfull) - (runs:queue-next-tal tal reg reglen regfull) - (runs:queue-next-reg tal reg reglen regfull) - reruns)) - (list (car newtal)(append (cdr newtal) reg) '() reruns)))) - + (let ((trimmed-tal (mt:discard-blocked-tests run-id hed tal test-records)) + (trimmed-reg (mt:discard-blocked-tests run-id hed reg test-records))) + (debug:print 1 "WARNING: test " hed " has discarded prerequisites, removing it from the queue") + (if (and (null? trimmed-tal) + (null? trimmed-reg)) + #f + (list (runs:queue-next-hed trimmed-tal trimmed-reg reglen regfull) + (runs:queue-next-tal trimmed-tal trimmed-reg reglen regfull) + (runs:queue-next-reg trimmed-tal trimmed-reg reglen regfull) + reruns))) + (list (car newtal)(append (cdr newtal) reg) '() reruns)))) ;; (debug:print-info 1 "allinqueue: " allinqueue) ;; (debug:print-info 1 "prereqstrs: " prereqstrs) ;; (debug:print-info 1 "notinqueue: " notinqueue) ;; (debug:print-info 1 "tal: " tal) @@ -874,11 +877,11 @@ ;; EXPAND ITEMS ((or (procedure? items)(eq? items 'have-procedure)) (let ((can-run-more (runs:can-run-more-tests jobgroup max-concurrent-jobs))) (if (and (list? can-run-more) (car can-run-more)) - (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry))) + (let ((loop-list (runs:expand-items hed tal reg reruns regfull newtal jobgroup max-concurrent-jobs run-id waitons item-path testmode test-record can-run-more items runname tconfig reglen test-registry test-records))) (if loop-list (apply loop loop-list))) ;; if can't run more just loop with next possible test (loop (car newtal)(cdr newtal) reg reruns))))