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 Unified 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

;; (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 ")")))))
︙︙
484
485
486
487
488
489
490







491
492
493
494
495
496
497

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








>
>
>
>
>
>
>








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

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








>
>
>
>
>
>
>
>
>








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.108s by Fossil 2.24 [452f8e1ffc] 2024-03-26 15:36:00