Megatest

Check-in [4daccede49]
Login
☰Home Timeline Files Branches Tags Tickets Wiki Login
Overview
Comment:Added variable watcher debugger thingy (might help until feathers is usable)
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | v1.61
Files: files | file ages | folders
SHA1: 4daccede49bdb43e1df141aaaa59de2ffa0477e5
User & Date: matt on 2016-05-12 23:09:14
Other Links: branch diff | manifest | tags
Context
2016-05-13
00:06
minor improvements to debugger check-in: 28c2958fa3 user: matt tags: v1.61
2016-05-12
23:09
Added variable watcher debugger thingy (might help until feathers is usable) check-in: 4daccede49 user: matt tags: v1.61
2016-05-11
22:46
Bumped level to 2 for flexilauncher messages check-in: 021e278f39 user: matt tags: v1.61
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Added debugger.scm version [d03c93cb9e]. 









































































1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71

+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

(use iup)

(define *debugger-control* #f)
(define *debugger-rownum*  0)
(define *debugger-matrix*  #f)
(define *debugger*         #f)

(define (debugger)
  (if (not *debugger*)
      (set! *debugger* 
	    (thread-start!
	     (make-thread
	      (lambda ()
		(show
		 (dialog
		  (let ((pause #f)
			(mtrx  (matrix
				#:expand "YES"
				#:numlin 30
				#:numcol 3
				#:numlin-visible 20
				#:numcol-visible 3
				)))
		    (set! pause (button "Pause" 
					#:action (lambda (obj)
						   (set! *debugger-control* (not *debugger-control*))
						   (attribute-set! pause "BGCOLOR" (if *debugger-control*
										       "200 0 0"
										       "0 0 200")))))
		    (set! *debugger-matrix* mtrx)
		    (attribute-set! mtrx "WIDTH1" "200")
		    (vbox
		     mtrx
		     (hbox
		      pause)))))
		(main-loop)))))))

(define (debugger-start #!key (start 1))
  (set! *debugger-rownum* start))

(define (debugger-trace-var varname varval)
  (let ((oldval (attribute *debugger-matrix* (conc *debugger-rownum* ":1")))
	(newval (conc varval)))
    (if (not (equal? oldval newval))
	(begin
	  ;; (print "DEBUG: " varname " = " newval)
	  (attribute-set! *debugger-matrix* (conc *debugger-rownum* ":0") varname)
	  (attribute-set! *debugger-matrix* (conc *debugger-rownum* ":1") (conc varval))
	  ;; (attribute-set! *debugger-matrix* "FITTOTEXT" "C1")
	  ))
    (set! *debugger-rownum* (+ *debugger-rownum* 1))))


(define (debugger-pauser)
  (debugger)
  (attribute-set! *debugger-matrix* "REDRAW" "ALL")
  (let loop ()
    (if *debugger-control*
	(begin
	  (print "PAUSED!")
	  (thread-sleep! 1)
	  (loop))
	(thread-sleep! 0.01))))
		  
;;    ;; lets use the debugger eh?
;;    (debugger-start)
;;    (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)









Modified runs.scm
from [2bc02d7933]
to [68632cd62e].




︙


25
26
27
28
29
30
31


32
33
34
35
36
37
38

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






︙


484
485
486
487
488
489
490







491
492
493
494
495
496
497

486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506








+
+
+
+
+
+
+








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




︙


1028
1029
1030
1031
1032
1033
1034









1035
1036
1037
1038
1039
1040
1041

1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059








+
+
+
+
+
+
+
+
+








		     "\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: 5)
	(debugger-trace-var "runs:run-tests-queue" "")
	(debugger-trace-var "items"            items)
	(debugger-trace-var "hed"              hed)
	(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))))




︙












This page was generated in about
0.101s by
Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00