304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
|
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
|
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
|
(print-call-chain *default-log-port*)
(debug:print 0 *default-log-port* "Message: " ((condition-property-accessor 'exn 'message) exn))
(debug:print 0 *default-log-port* "ERROR: failed to run post-hook " run-post-hook ", check the log " log-file))
(debug:print-info 0 *default-log-port* "running run-post-hook: \"" run-post-hook "\", log is " actual-logf)
(system (conc run-post-hook " >> " actual-logf " 2>&1"))
(debug:print-info 0 *default-log-port* "post-hook \"" run-post-hook "\" took " (- (current-seconds) start-time) " seconds to run."))))))
(define (runs:testpatts-mention-waitors-upon? testpatts waitors-upon)
(print "NOT IMPLEMENTED")
(exit 1)
#f)
;; return #t when all items in waitors-upon list are represented in test-patt, #f otherwise.
(define (runs:testpatts-mention-waitors-upon? test-patt waitors-upon)
(let* ((tests-in-testpatt
(map
(lambda (test-patt-item)
(car (string-split test-patt-item "/")))
(string-split test-patt ",")))
(waitors-upon-not-mentioned (lset-difference equal? waitors-upon tests-in-testpatt)))
(null? waitors-upon-not-mentioned)))
;; test-names: Comma separated patterns same as test-patts but used in selection
;; of tests to run. The item portions are not respected.
;; FIXME: error out if /patt specified
;;
(define (runs:run-tests target runname test-patts user flags #!key (run-count 1)) ;; test-names
(let* ((keys (keys:config-get-fields *configdat*))
|
476
477
478
479
480
481
482
483
484
485
486
487
488
489
|
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
|
+
|
;; What happended, this code is now duplicated in tests!?
;;
;;======================================================================
(if (not (null? test-names))
(let loop ((hed (car test-names)) ;; NOTE: This is the main loop that iterates over the test-names
(tal (cdr test-names))) ;; 'return-procs tells the config reader to prep running system but return a proc
(debug:print-info 4 *default-log-port* "\n\ntestpatt elaboration loop => hed="hed " tal="tal" test-patts="test-patts" test-names="test-names)
(change-directory *toppath*) ;; PLEASE OPTIMIZE ME!!! I think this should be a no-op but there are several places where change-directories could be happening.
(setenv "MT_TEST_NAME" hed) ;;
(let*-values (((waitons waitors config)
(tests:get-waitons hed all-tests-registry)))
(debug:print-info 8 *default-log-port* "waitons: " waitons)
;; check for hed in waitons => this would be circular, remove it and issue an
;; error
|
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
|
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
|
+
-
-
+
+
+
-
+
-
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
#f ;; spare - used for item-path
waitors ;;
)))
;; update waitors-upon here
(for-each
(lambda (waiton)
(let* ((current-waitors-upon (hash-table-ref/default waitors-upon waiton '())))
(debug:print-info 8 *default-log-port* " current-waiters-upon["waiton"] is "current-waitors-upon )
(if (not (member hed current-waitors-upon))
(hash-table-set! waitors-upon waiton (cons hed current-waitors-upon)))))
(when (not (member hed current-waitors-upon))
(debug:print-info 8 *default-log-port* " current-waiters-upon["waiton"] << "hed )
(hash-table-set! waitors-upon waiton (cons hed current-waitors-upon)))))
(if (list? waitons) waitons '()))
(debug:print-info 8 *default-log-port* " process waitons&waitors of "hed": "(delete-duplicates (append waitons waitors)))
(for-each
(lambda (waiton)
(if (and waiton (not (member waiton test-names)))
(let* ((waitors-in-testpatt (runs:testpatts-mention-waitors-upon? testpatts (hash-table-ref/default waitors-upon waiton '())))
(let* ((waitors-in-testpatt (runs:testpatts-mention-waitors-upon? test-patts (hash-table-ref/default waitors-upon waiton '())))
(waiton-record (hash-table-ref/default test-records waiton #f))
(waiton-tconfig (if waiton-record (vector-ref waiton-record 1) #f))
(waiton-itemized (and waiton-tconfig
(or (hash-table-ref/default waiton-tconfig "items" #f)
(hash-table-ref/default waiton-tconfig "itemstable" #f))))
(itemmaps (tests:get-itemmaps config)) ;; (configf:lookup config "requirements" "itemmap"))
(new-test-patts (tests:extend-test-patts test-patts hed waiton itemmaps))) ;; BB: items expanded here - chained-waiton goes awry by now.
(debug:print-info 0 *default-log-port* "Test " waiton " has " (if waiton-record "a" "no") " waiton-record and" (if waiton-itemized " " " no ") "items")
;; need to account for test-patt here, if I am test "a", selected with a test-patt of "hed/b%"
;; and we are waiting on "waiton" we need to add "waiton/,waiton/b%" to test-patt
;; is this satisfied by merely appending "/" to the waiton name added to the list?
;;
;; This approach causes all of the items in an upstream test to be run
;; if we have this waiton already processed once we can analzye it for extending
;; tests to be run, since we can't properly process waitons unless they have been
;; initially added we add them again to be processed on second round AND add the hed
;; back in to also be processed on second round
;;
(if waiton-tconfig ;; BB: waiter should be in test-patts as well as the waiton have a tconfig.
(begin
(set! test-names (cons waiton test-names)) ;; need to process this one, only add once the waiton tconfig read
(if waiton-itemized
(if waitors-in-testpatt
(begin
(debug:print-info 0 *default-log-port* "New test patts: " new-test-patts ", prev test patts: " test-patts)
(set! required-tests (cons (conc waiton "/") required-tests))
(set! test-patts new-test-patts))
(begin
(debug:print-info 0 *default-log-port* "Waitor(s) not yet on testpatt for " waiton ", setting up to re-process it")
(set! tal (append (cons waiton tal)(list hed)))))
(begin
(debug:print-info 0 *default-log-port* "Adding non-itemized test " waiton " to required-tests")
(set! required-tests (cons waiton required-tests))
(set! test-patts new-test-patts))))
|