Megatest

Check-in [cfdbfe1a43]
Login
Overview
Comment:Fixed divide by zero problem
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.60
Files: files | file ages | folders
SHA1: cfdbfe1a4300c1cb9acd11a1651018f807092bb9
User & Date: mrwellan on 2015-10-08 08:47:57
Other Links: branch diff | manifest | tags
Context
2015-10-08
09:13
Added check for directory availability (to handle NFS quirk) before executing a test check-in: a22586ca18 user: mrwellan tags: v1.60
08:47
Fixed divide by zero problem check-in: cfdbfe1a43 user: mrwellan tags: v1.60
2015-10-06
23:59
Added some primitive arrows to dashboard tests display, played with different options on sort by waiton/priority but it seems to not be respected ... check-in: 01ebfc1ba9 user: matt tags: v1.60
Changes

Modified dcommon.scm from [626e737efc] to [edd2f9b1a7].

593
594
595
596
597
598
599


600

601
602
603






604
605
606
607
608
609
610
593
594
595
596
597
598
599
600
601

602
603


604
605
606
607
608
609
610
611
612
613
614
615
616







+
+
-
+

-
-
+
+
+
+
+
+







(define (dcommon:draw-arrow cnv test-box-center waiton-center)
  (let* ((test-box-center-x (vector-ref test-box-center 0))
	 (test-box-center-y (vector-ref test-box-center 1))
	 (waiton-center-x   (vector-ref waiton-center   0))
	 (waiton-center-y   (vector-ref waiton-center   1))
	 (delta-y           (- waiton-center-y test-box-center-y))
	 (delta-x           (- waiton-center-x test-box-center-x))
	 (abs-delta-x       (abs delta-x))
	 (abs-delta-y       (abs delta-y))
	 (use-delta-x       (> (abs delta-x)(abs delta-y))) ;; use the larger one
	 (use-delta-x       (> abs-delta-x abs-delta-y)) ;; use the larger one
	 (delta-ratio       (if use-delta-x
				(/ (abs delta-y)(abs delta-x))
				(/ (abs delta-x)(abs delta-y))))
				(if (> abs-delta-x 0)
				    (/ abs-delta-y abs-delta-x)
				    1)
				(if (> abs-delta-y 0)
				    (/ abs-delta-x abs-delta-y)
				    1)))
	 (x-adj             (if use-delta-x
				8
				(* delta-ratio 8)))
	 (y-adj             (if use-delta-x
				(* x-adj delta-ratio)
				8))
	 (new-waiton-x      (inexact->exact

Modified tests.scm from [ed3dfc9807] to [86ae662ea5].

765
766
767
768
769
770
771









772
773
774
775
776
777


778
779
780
781
782
783
784
785










786
787

















788
789
790
791
792
793
794
795

796
797
798
799
800
801
802
803
804
805
806
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784


785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804


805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825




826




827
828
829
830
831
832
833







+
+
+
+
+
+
+
+
+




-
-
+
+








+
+
+
+
+
+
+
+
+
+
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+




-
-
-
-
+
-
-
-
-







;; Move test specific stuff to a test unit FIXME one of these days
(define (tests:sort-by-priority-and-waiton test-records)
  (let* ((mungepriority (lambda (priority)
			  (if priority
			      (let ((tmp (any->number priority)))
				(if tmp tmp (begin (debug:print 0 "ERROR: bad priority value " priority ", using 0") 0)))
			      0)))
	 (all-tests      (hash-table-keys test-records))
	 (all-waited-on  (let loop ((hed (car all-tests))
				    (tal (cdr all-tests))
				    (res '()))
			   (let* ((trec    (hash-table-ref test-records hed))
				  (waitons (or (tests:testqueue-get-waitons trec) '())))
			     (if (null? tal)
				 (append res waitons)
				 (loop (car tal)(cdr tal)(append res waitons))))))
	 (sort-fn1 
	  (lambda (a b)
	    (let* ((a-record   (hash-table-ref test-records a))
		   (b-record   (hash-table-ref test-records b))
		   (a-waitons  (tests:testqueue-get-waitons a-record))
		   (b-waitons  (tests:testqueue-get-waitons b-record))
		   (a-waitons  (or (tests:testqueue-get-waitons a-record) '()))
		   (b-waitons  (or (tests:testqueue-get-waitons b-record) '()))
		   (a-config   (tests:testqueue-get-testconfig  a-record))
		   (b-config   (tests:testqueue-get-testconfig  b-record))
		   (a-raw-pri  (config-lookup a-config "requirements" "priority"))
		   (b-raw-pri  (config-lookup b-config "requirements" "priority"))
		   (a-priority (mungepriority a-raw-pri))
		   (b-priority (mungepriority b-raw-pri)))
	      (tests:testqueue-set-priority! a-record a-priority)
	      (tests:testqueue-set-priority! b-record b-priority)
	      (debug:print 0 "a=" a ", b=" b ", a-waitons=" a-waitons ", b-waitons=" b-waitons)
	      (cond
	       ;; is 
	       ((member a b-waitons)          ;; is b waiting on a?
		(debug:print 0 "case1")
		#t)
	       ((member b a-waitons)          ;; is a waiting on b?
		(debug:print 0 "case2")
		#f)
	       ((and (not (null? a-waitons))  ;; both have waitons - do not disturb
	      (or (and b-waitons (member (tests:testqueue-get-testname a-record) b-waitons))
		  (not b-waitons)))))
		     (not (null? b-waitons)))
		(debug:print 0 "case2.1")
		#t)
	       ((and (null? a-waitons)        ;; no waitons for a but b has waitons
		     (not (null? b-waitons)))
		(debug:print 0 "case3")
		#f)
	       ((and (not (null? a-waitons))  ;; a has waitons but b does not
		     (null? b-waitons)) 
		(debug:print 0 "case4")
		#t)
	       ((not (eq? a-priority b-priority)) ;; use
		(> a-priority b-priority))
	       (else
		(debug:print 0 "case5")
		(string>? a b))))))
	 
	 (sort-fn2
	  (lambda (a b)
	    (> (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records a)))
	       (mungepriority (tests:testqueue-get-priority (hash-table-ref test-records b)))))))
    (sort
     (sort
      (sort
       (sort (hash-table-keys test-records) ;; avoid dealing with deleted tests, look at the hash table
    (sort all-tests sort-fn1))) ;; avoid dealing with deleted tests, look at the hash table
	     sort-fn1) ;; first once by waiton
       sort-fn2)       ;; second by priority
      sort-fn1)
     sort-fn1)))      ;; third by waiton again

;; for each test:
;;   
(define (tests:filter-non-runnable run-id testkeynames testrecordshash)
  (let ((runnables '()))
    (for-each
     (lambda (testkeyname)