Megatest

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

			    (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)))
			  (begin
			    (debug:print 1 "WARN: Test not processed correctly. Could be a race condition in your test implementation? " hed) ;;  " as it has prerequistes that are FAIL. (NOTE: hed is not a vector)")
			    (runs:shrink-can-run-more-tests-count) ;; DELAY TWEAKER (still needed?)
			    ;; (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

	  ;; (loop hed tal reg reruns))
	  ;; (let ((newtal (append tal (list hed))))  ;; We should discard hed as it has been expanded into it's items?
	  ;;   (loop (car newtal)(cdr newtal) reg reruns)) ;; )
	  (loop (car tal)(cdr tal) 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
			      (tests:testqueue-set-items! test-record items-list)
			      ;; (thread-sleep! *global-delta*)
			      (loop hed tal reg reruns))
			    (begin
			      (debug:print 0 "ERROR: The proc from reading the setup did not yield a list - please report this")
			      (exit 1))))))
		   ((null? fails)
		    (debug:print-info 4 "fails is null, moving on in the queue but keeping " hed " for now")
		    ;; only increment num-retries when there are no tests runing
		    (if (eq? 0 (list-ref can-run-more 1))
			(begin
			  ;; TRY (if (> num-retries 100) ;; first 100 retries are low time cost
			  ;; TRY     (thread-sleep! (+ 2 *global-delta*))
			  ;; TRY     (thread-sleep! (+ 0.01 *global-delta*)))
			  (set! num-retries (+ num-retries 1))))
		    (if (> num-retries  max-retries)
			(begin
			  (debug:print 0 "WARNING: retries exceed " max-retries ", this may not be handled correctly. Please consider reporting this scenario.")
			  (if (not (null? tal))
			      (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)))
			(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
		    (debug:print 4 "ERROR: No handler for this condition.")
		    ;; TRY (thread-sleep! (+ 1 *global-delta*))
		    (loop (car newtal)(cdr newtal) reg reruns)))) ;; END OF IF CAN RUN MORE

		;; if can't run more just loop with next possible test
		(begin
		  (debug:print-info 4 "processing the case with a lambda for items or 'have-procedure. Moving through the queue without dropping " hed)
		  ;; (thread-sleep! (+ 2 *global-delta*))
		  (loop (car newtal)(cdr newtal) reg reruns))))) ;; END OF (or (procedure? items)(eq? items 'have-procedure))
	 
	 ;; this case should not happen, added to help catch any bugs
	 ((and (list? items) itemdat)
	  (debug:print 0 "ERROR: Should not have a list of items in a test and the itemspath set - please report this")
	  (exit 1))
	 ((not (null? reruns))
	  (let* ((newlst (tests:filter-non-runnable run-id tal test-records)) ;; i.e. not FAIL, WAIVED, INCOMPLETE, PASS, KILLED,
		 (junked (lset-difference equal? tal newlst)))