Megatest

    (debug:print-info 4 "test-records=" (hash-table->alist test-records))
    (let ((reglen (configf:lookup *configdat* "setup" "runqueue")))
      (if (> (length (hash-table-keys test-records)) 0)
	  (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests (any->number reglen))
	  (debug:print-info 0 "No tests to run")))
    (debug:print-info 4 "All done by here")))


;; loop logic. These are used in runs:run-tests-queue to make it a bit more readable.
;;
;; If reg not full and have items in tal then loop with (car tal)(cdr tal) reg reruns
;; If reg is full (i.e. length >= n
;;   loop with (car reg) tal (cdr reg) reruns
;; If tal is empty
;;   but have items in reg; loop with (car reg)(cdr reg) '() reruns
;;   If reg is empty => all done

(define (runs:queue-next-hed tal reg n regful)
  (if regful
      (car reg)
      (if (null? tal) ;; tal is used up, pop from reg
	  (car reg)
	  (car tal))))

(define (runs:queue-next-tal tal reg n regful)
  (if regful
      tal
      (if (null? tal) ;; must transfer from reg
	  (cdr reg)
	  (cdr tal))))

(define (runs:queue-next-reg tal reg n regful)
  (if regful
      (cdr reg)
      (if (null? tal) ;; if tal is null and reg not full then '() as reg contents moved to tal
	  '()
	  reg)))

;; test-records is a hash table testname:item_path => vector < testname testconfig waitons priority items-info ... >
(define (runs:run-tests-queue run-id runname test-records keyvals flags test-patts required-tests reglen-in)
  ;; At this point the list of parent tests is expanded 
  ;; NB// Should expand items here and then insert into the run queue.
  (debug:print 5 "test-records: " test-records ", flags: " (hash-table->alist flags))
  (let ((run-info              (cdb:remote-run db:get-run-info #f run-id))
	(tests-info            (mt:get-tests-for-run run-id #f '() '())) ;;  qryvals: "id,testname,item_path"))
	(sorted-test-names     (tests:sort-by-priority-and-waiton test-records))
	(test-registry         (make-hash-table))
	(registry-mutex        (make-mutex))
	(num-retries           0)
	(max-retries           (config-lookup *configdat* "setup" "maxretries"))
	(max-concurrent-jobs   (let ((mcj (config-lookup *configdat* "setup"     "max_concurrent_jobs")))
				 (if (and mcj (string->number mcj))
				     (string->number mcj)
				     1))) ;; length of the register queue ahead
	(reglen                (if (number? reglen-in) reglen-in 1)))

    ;; Initialize the test-registery hash with tests that already have a record
    ;; convert state to symbol and use that as the hash value
    (for-each (lambda (trec)
		(let ((id (db:test-get-id        trec))
		      (tn (db:test-get-testname  trec))
		      (ip (db:test-get-item-path trec))
		      (st (db:test-get-state     trec)))
		  (hash-table-set! test-registry (runs:make-full-test-name tn ip) (string->symbol st))))
	      tests-info)

	     (items       (tests:testqueue-get-items      test-record))
	     (item-path   (item-list->path itemdat))
	     (tfullname   (runs:make-full-test-name test-name item-path))
	     (newtal      (append tal (list hed)))
	     (regfull     (>= (length reg) reglen)))

	;; Fast skip of tests that are already "COMPLETED"
	;;
	(if (equal? (hash-table-ref/default test-registry tfullname #f) 'COMPLETED)
	    (begin
	      (debug:print-info 0 "Skipping COMPLETED test " tfullname)
	      (if (not (null? tal))
		  (loop (car tal)(cdr tal) reg reruns))))

	(debug:print 4 "TOP OF LOOP => "
		     "test-name: " test-name
		     "\n  test-record  " test-record
		     "\n  hed:         " hed
		     "\n  itemdat:     " itemdat
		     "\n  items:       " items
		     "\n  item-path:   " item-path
		     "\n  waitons:     " waitons
		     "\n  num-retries: " num-retries
		     "\n  tal:         " tal
		     "\n  reruns:      " reruns
		     "\n  regfull:     " regfull
		     "\n  reglen:      " reglen
		     "\n  length reg:  " (length reg)
		     "\n  reg:         " reg)

	;; check for hed in waitons => this would be circular, remove it and issue an
	;; error
	(if (member test-name waitons)
	    (begin
	      (debug:print 0 "ERROR: test " test-name " has listed itself as a waiton, please correct this!")
	      (set! waiton (filter (lambda (x)(not (equal? x hed))) waitons))))

	(cond ;; OUTER COND

	 ;; items is #f then the test is ok to be handed off to launch (but not before)
	 ;; 
	 ((not items)
	  (debug:print-info 4 "OUTER COND: (not items)")
	  (if (and (not (tests:match test-patts (tests:testqueue-get-testname test-record) item-path required: required-tests))
		   (not (null? tal)))
	      (loop (car tal)(cdr tal) reg reruns))
	  (let* ((run-limits-info         (runs:can-run-more-tests jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
		 ;; (open-run-close runs:can-run-more-tests #f jobgroup max-concurrent-jobs)) ;; look at the test jobgroup and tot jobs running
		 (have-resources          (car run-limits-info))
		 (num-running             (list-ref run-limits-info 1))
		 (num-running-in-jobgroup (list-ref run-limits-info 2))
		 (max-concurrent-jobs     (list-ref run-limits-info 3))
		 (job-group-limit         (list-ref run-limits-info 4))
		 (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 "have-resources: " have-resources " prereqs-not-met: (" 
			      (string-intersperse 
			       (map (lambda (t)
				      (if (vector? t)
					  (conc (db:test-get-state t) "/" (db:test-get-status t))
					  (conc " WARNING: t is not a vector=" t )))
				    prereqs-not-met) ", ") ") fails: " fails)
	    (debug:print-info 4 "hed=" hed "\n  test-record=" test-record "\n  test-name: " test-name "\n  item-path: " item-path "\n  test-patts: " test-patts)

	    ;; Don't know at this time if the test have been launched at some time in the past
	    ;; i.e. is this a re-launch?
	    (debug:print-info 4 "run-limits-info = " run-limits-info)

	    (cond ;; INNER COND #1 for a launchable test

		  (loop (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)))

	     ;; Register tests 
	     ;;
	     ((not (hash-table-ref/default test-registry (runs:make-full-test-name test-name item-path) #f))
	      (debug:print-info 4 "Pre-registering test " test-name "/" item-path " to create placeholder" )
	      (let ((th (make-thread (lambda ()
				       (mutex-lock! registry-mutex)
				       (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'start)
				       (mutex-unlock! registry-mutex)
				       ;; If haven't done it before register a top level test if this is an itemized test
				       (if (not (eq? (hash-table-ref/default test-registry (runs:make-full-test-name test-name "") #f) 'done))

	     ;; This is the final stage, everything is in place so launch the test
	     ;;
	     ((and have-resources
		   (or (null? prereqs-not-met)
		       (and (eq? testmode 'toplevel)
			    (null? non-completed))))
	      (run:test run-id run-info keyvals runname test-record flags #f test-registry)
	      (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'running)
	      (runs:shrink-can-run-more-tests-count)  ;; DELAY TWEAKER (still needed?)
	      ;; (thread-sleep! *global-delta*)
	      (if (or (not (null? tal))(not (null? reg)))
		  (loop (runs:queue-next-hed tal reg reglen regfull)
			(runs:queue-next-tal tal reg reglen regfull)
			(runs:queue-next-reg tal reg reglen regfull)

		  (begin
		    ;; couldn't run, take a breather
		    (debug:print-info 4 "Shouldn't really get here, race condition? Unable to launch more tests at this moment, killing time ...")
		    ;; (thread-sleep! (+ 0.01 *global-delta*)) ;; long sleep here - no resources, may as well be patient
		    ;; we made new tal by sticking hed at the back of the list
		    (loop (car newtal)(cdr newtal) reg reruns))
		  ;; the waiton is FAIL so no point in trying to run hed ever again
		  (if (or (not (null? reg))(not (null? tal)))
		      (if (vector? hed)
			  (begin 
			    (debug:print 1 "WARN: Dropping test " (db:test-get-testname hed) "/" (db:test-get-item-path hed)
					 " from the launch list as it has prerequistes that are FAIL")
			    (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
			    ;; (thread-sleep! *global-delta*)
			    (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'removed)

			    ;; (thread-sleep! (+ 0.01 *global-delta*))
			    (loop hed tal reg reruns))))))))) ;; END OF INNER COND

	 ;; End of INNER COND for launchable test.

	 ;; case where an items came in as a list been processed
	 ((and (list? items)     ;; thus we know our items are already calculated
	       (not   itemdat))  ;; and not yet expanded into the list of things to be done
	  (debug:print-info 4 "INNER COND: (and (list? items)(not itemdat))")
	  (if (and (debug:debug-mode 1) ;; (>= *verbosity* 1)
		   (> (length items) 0)
		   (> (length (car items)) 0))
	      (pp items))
	  (for-each
	   (lambda (my-itemdat)
	     (let* ((new-test-record (let ((newrec (make-tests:testqueue)))

	  ;; (loop hed tal reg reruns))
	  (let ((newtal (append tal (list hed))))
	    (loop (car newtal)(cdr newtal) reg reruns)))
	    
	 ;; if items is a proc then need to run items:get-items-from-config, get the list and loop 
	 ;;    - but only do that if resources exist to kick off the job
	 ((or (procedure? items)(eq? items 'have-procedure))
	  (debug:print-info 4 "INNER COND: (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* ((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 "
				    "\n can-run-more:    " can-run-more
				    "\n testname:        " hed
				    "\n prereqs-not-met: " (runs:pretty-string prereqs-not-met)
				    "\n non-completed:   " (runs:pretty-string non-completed) 
				    "\n fails:           " (runs:pretty-string fails)
				    "\n testmode:        " testmode
				    "\n num-retries:     " num-retries
				    "\n (eq? testmode 'toplevel): " (eq? testmode 'toplevel)
				    "\n (null? non-completed):    " (null? non-completed)
				    "\n reruns:          " reruns
				    "\n items:           " items
				    "\n can-run-more:    " can-run-more)
		  ;; (thread-sleep! (+ 0.01 *global-delta*))
		  (cond ;; INNER COND #2
		   ((or (null? prereqs-not-met) ;; all prereqs met, fire off the test
			;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch
			(and (eq? testmode 'toplevel)
			     (null? non-completed)))
		    (debug:print-info 4 "INNER COND #2: (or (null? prereqs-not-met) (and (eq? testmode 'toplevel)(null? non-completed)))")
		    (let ((test-name (tests:testqueue-get-testname test-record)))
		      (setenv "MT_TEST_NAME" test-name) ;; 
		      (setenv "MT_RUNNAME"   runname)
		      (set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
		      (let ((items-list (items:get-items-from-config tconfig)))
			(if (list? items-list)
			    (begin

				  (runs:queue-next-reg tal reg reglen regfull)
				  reruns))
			(loop (car newtal)(cdr newtal) reg reruns))) ;; an issue with prereqs not yet met?
		   ((and (not (null? fails))(eq? testmode 'normal))
		    (debug:print-info 1 "test "  hed " (mode=" testmode ") has failed prerequisite(s); "
				      (string-intersperse (map (lambda (t)(conc (db:test-get-testname t) ":" (db:test-get-state t)"/"(db:test-get-status t))) fails) ", ")
				      ", removing it from to-do list")
		    (if (or (not (null? reg))(not (null? tal)))
			(begin
			  ;; (thread-sleep! *global-delta*)
			  (loop (runs:queue-next-hed tal reg reglen regfull)
				(runs:queue-next-tal tal reg reglen regfull)
				(runs:queue-next-reg tal reg reglen regfull)
				(cons hed reruns)))))
		   (else

	 ((not (null? reg)) ;; could we get here with leftovers?
	  (debug:print-info 0 "Have leftovers!")
	  (loop (car reg)(cdr reg) '() reruns))
	 (else
	  (debug:print-info 4 "Exiting loop with...\n  hed=" hed "\n  tal=" tal "\n  reruns=" reruns))
	 ))) ;; LET* ((test-record
    
    ;; we get here on "drop through". All done!


    (debug:print-info 1 "All tests launched")))

(define (runs:calc-fails prereqs-not-met)
  (filter (lambda (test)
	    (and (vector? test) ;; not (string? test))
		 (equal? (db:test-get-state test) "COMPLETED")
		 (not (member (db:test-get-status test)

	     (conc t)
	     (conc (db:test-get-testname t) ":" (db:test-get-state t) "/" (db:test-get-status t))))
       lst))

(define (runs:make-full-test-name testname itempath)
  (if (equal? itempath "") testname (conc testname "/" itempath)))































;; parent-test is there as a placeholder for when parent-tests can be run as a setup step
(define (run:test run-id run-info keyvals runname test-record flags parent-test test-registry)
  ;; All these vars might be referenced by the testconfig file reader
  (let* ((test-name    (tests:testqueue-get-testname   test-record))
	 (test-waitons (tests:testqueue-get-waitons    test-record))
	 (test-conf    (tests:testqueue-get-testconfig test-record))
	 (itemdat      (tests:testqueue-get-itemdat    test-record))
	 (test-path    (conc *toppath* "/tests/" test-name)) ;; could use tests:get-testconfig here ...
	 (force        (hash-table-ref/default flags "-force" #f))
	 (rerun        (hash-table-ref/default flags "-rerun" #f))
	 (keepgoing    (hash-table-ref/default flags "-keepgoing" #f))
	 (item-path     "")
	 (db           #f))
    (debug:print 4
		 "test-config: " (hash-table->alist test-conf)
		 "\n   itemdat: " itemdat
		 )
    ;; setting itemdat to a list if it is #f
    (if (not itemdat)(set! itemdat '()))
    (set! item-path (item-list->path itemdat))
    (debug:print 2 "Attempting to launch test " test-name (if (equal? item-path "")""(conc "/" item-path)))
    (setenv "MT_TEST_NAME" test-name) ;; 
    (setenv "MT_RUNNAME"   runname)
    (set-megatest-env-vars run-id inrunname: runname) ;; these may be needed by the launching process
    (change-directory *toppath*)

    ;; Here is where the test_meta table is best updated
    ;; Yes, another use of a global for caching. Need a better way?

	    ;; not -rerun and PASS, WARN or CHECK, do no run
	    ((and (or (not rerun)
		      keepgoing)
		  ;; Require to force re-run for COMPLETED or *anything* + PASS,WARN or CHECK
		  (or (member (test:get-status testdat) '("PASS" "WARN" "CHECK" "SKIP"))
		      (member (test:get-state  testdat) '("COMPLETED")))) 
	     (debug:print-info 2 "running test " test-name "/" item-path " suppressed as it is " (test:get-state testdat) " and " (test:get-status testdat))
	     (hash-table-set! test-registry (runs:make-full-test-name test-name item-path) 'COMPLETED)
	     (set! runflag #f))
	    ;; -rerun and status is one of the specifed, run it
	    ((and rerun
		  (let* ((rerunlst   (string-split rerun ","))
			 (must-rerun (member (test:get-status testdat) rerunlst)))
		    (debug:print-info 3 "-rerun list: " rerun ", test-status: " (test:get-status testdat)", must-rerun: " must-rerun)
		    must-rerun))