| ︙ | | | ︙ | |
25
26
27
28
29
30
31
32
33
34
35
36
37
38
|
;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(define (runs:test-get-full-path test)
(let* ((testname (db:test-get-testname test))
(itempath (db:test-get-item-path test)))
(conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))
|
>
>
|
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
|
;; (declare (uses filedb))
(include "common_records.scm")
(include "key_records.scm")
(include "db_records.scm")
(include "run_records.scm")
(include "test_records.scm")
(include "debugger.scm")
(define (runs:test-get-full-path test)
(let* ((testname (db:test-get-testname test))
(itempath (db:test-get-item-path test)))
(conc testname (if (equal? itempath "") "" (conc "(" itempath ")")))))
|
| ︙ | | | ︙ | |
157
158
159
160
161
162
163
164
165
166
167
168
169
170
|
((and job-group-limit
(>= num-running-in-jobgroup job-group-limit))
(if (runs:lownoise (conc "maxjobgroup " jobgroup) 60)
(debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup
" in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit))
#t)
(else #f))))
(list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)))))
;; 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
;;
|
>
>
>
>
>
>
>
>
|
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
((and job-group-limit
(>= num-running-in-jobgroup job-group-limit))
(if (runs:lownoise (conc "maxjobgroup " jobgroup) 60)
(debug:print 1 "WARNING: number of jobs " num-running-in-jobgroup
" in jobgroup \"" jobgroup "\" exceeds limit of " job-group-limit))
#t)
(else #f))))
;; lets use the debugger eh?
(debugger-start start: 15)
(debugger-trace-var "runs:can-run-more-tests" "")
(debugger-trace-var "can-not-run-more" can-not-run-more)
(debugger-trace-var "num-running" num-running)
(debugger-trace-var "num-running-in-jobgroup" num-running-in-jobgroup)
(debugger-trace-var "job-group-limit" job-group-limit)
(debugger-pauser)
(list (not can-not-run-more) num-running num-running-in-jobgroup max-concurrent-jobs job-group-limit)))))
;; 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
;;
|
| ︙ | | | ︙ | |
518
519
520
521
522
523
524
525
526
527
528
529
530
531
|
"\n fails: " (runs:pretty-string fails)
"\n testmode: " testmode
"\n (member 'toplevel testmode): " (member 'toplevel testmode)
"\n (null? non-completed): " (null? non-completed)
"\n reruns: " reruns
"\n items: " items
"\n can-run-more: " can-run-more)
(cond
;; all prereqs met, fire off the test
;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch
((and (not (member 'toplevel testmode))
(member (hash-table-ref/default test-registry (db:test-make-full-name hed item-path) 'n/a)
|
>
>
>
>
>
>
>
>
|
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
|
"\n fails: " (runs:pretty-string fails)
"\n testmode: " testmode
"\n (member 'toplevel testmode): " (member 'toplevel testmode)
"\n (null? non-completed): " (null? non-completed)
"\n reruns: " reruns
"\n items: " items
"\n can-run-more: " can-run-more)
;; lets use the debugger eh?
(debugger-start start: 2)
(debugger-trace-var "runs:expand-items" "")
(debugger-trace-var "can-run-more" can-run-more)
(debugger-trace-var "hed" hed)
(debugger-trace-var "prereqs-not-met" (runs:pretty-string prereqs-not-met))
(debugger-pauser)
(cond
;; all prereqs met, fire off the test
;; or, if it is a 'toplevel test and all prereqs not met are COMPLETED then launch
((and (not (member 'toplevel testmode))
(member (hash-table-ref/default test-registry (db:test-make-full-name hed item-path) 'n/a)
|
| ︙ | | | ︙ | |
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
|
"\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))))
|
>
>
>
>
>
>
>
>
>
>
>
|
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
|
"\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)
;; lets use the debugger eh?
(debugger-start start: 7)
(debugger-trace-var "runs:run-tests-queue" "")
(debugger-trace-var "hed" hed)
(debugger-trace-var "tal" tal)
(debugger-trace-var "items" items)
(debugger-trace-var "item-path" item-path)
(debugger-trace-var "waitons" waitons)
(debugger-pauser)
;; 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))))
|
| ︙ | | | ︙ | |