321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
|
"Areas"
(string-intersperse (tree:node->path current-tree current-node) "/")))
(current-matrix (if (null? tab-ids) #f (tab-matrix current-tab)))
(seen-nodes (make-hash-table))
(path-changed (if current-tab
(equal? current-path (tab-view-path current-tab))
#t)))
;; (debug:print-info 0 #f "Current path: " current-path)
;; now for each area in the window gather the data
(if path-changed
(begin
(debug:print-info 0 #f "clearing matrix - path changed")
(dboard:clear-matrix current-tab)))
(for-each
(lambda (area-name)
;; (print "Processing for area-name " area-name)
(let* ((area-dat (hash-table-ref areas area-name))
(area-path (areadat-path area-dat))
(runs (areadat-runs area-dat)))
|
|
|
|
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
|
"Areas"
(string-intersperse (tree:node->path current-tree current-node) "/")))
(current-matrix (if (null? tab-ids) #f (tab-matrix current-tab)))
(seen-nodes (make-hash-table))
(path-changed (if current-tab
(equal? current-path (tab-view-path current-tab))
#t)))
;; (debug:print-info 0 *default-log-port* "Current path: " current-path)
;; now for each area in the window gather the data
(if path-changed
(begin
(debug:print-info 0 *default-log-port* "clearing matrix - path changed")
(dboard:clear-matrix current-tab)))
(for-each
(lambda (area-name)
;; (print "Processing for area-name " area-name)
(let* ((area-dat (hash-table-ref areas area-name))
(area-path (areadat-path area-dat))
(runs (areadat-runs area-dat)))
|
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
|
(tal (cdr state-statuses))
(count 1))
(if (not (equal? (iup:attribute current-matrix (conc "0:" count)) hed))
(iup:attribute-set! current-matrix (conc "0:" count) hed))
(iup:attribute-set! current-matrix (conc rownum ":" count) "0")
(if (not (null? tal))
(loop (car tal)(cdr tal)(+ count 1))))
(debug:print-info 0 #f "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name)
(iup:attribute-set! current-matrix coord area-name)
(set! changed #t))))))
(if changed (iup:attribute-set! current-matrix "REDRAW" "ALL"))))
;; (dboard:clear-matrix current-matrix used-cols used-rows touched) ;; clear all
|
|
|
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
|
(tal (cdr state-statuses))
(count 1))
(if (not (equal? (iup:attribute current-matrix (conc "0:" count)) hed))
(iup:attribute-set! current-matrix (conc "0:" count) hed))
(iup:attribute-set! current-matrix (conc rownum ":" count) "0")
(if (not (null? tal))
(loop (car tal)(cdr tal)(+ count 1))))
(debug:print-info 0 *default-log-port* "view-type=" view-type ", rownum=" rownum ", curr-rownum=" curr-rownum ", next-rownum=" next-rownum ", coord=" coord ", area-name=" area-name)
(iup:attribute-set! current-matrix coord area-name)
(set! changed #t))))))
(if changed (iup:attribute-set! current-matrix "REDRAW" "ALL"))))
;; (dboard:clear-matrix current-matrix used-cols used-rows touched) ;; clear all
|
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
|
(file-name (pathname-strip-directory fname))
(curr-mtcfgdat (find-config "megatest.config"
toppath: (or (get-environment-variable "MT_RUN_AREA_HOME")(current-directory))))
(curr-mtcfg (if (and curr-mtcfgdat (not (null? curr-mtcfgdat)))(cadr curr-mtcfgdat) #f))
(curr-mtpath (if curr-mtcfg (car curr-mtcfgdat) #f)))
(if curr-mtpath
(begin
(debug:print-info 0 #f "Creating config file " fname)
(if (not (file-exists? dirname))
(create-directory dirname #t))
(with-output-to-file fname
(lambda ()
(let ((aname (pathname-strip-directory curr-mtpath)))
(print "[" aname "]")
(print "path " curr-mtpath))))
#t)
(begin
(debug:print-info 0 #f "Need to create a config but no megatest.config found: " curr-mtcfgdat)
#f))))
;; )
(define (dboard:read-mtconf apath)
(let* ((mtconffile (conc apath "/megatest.config")))
(call-with-environment-variables
(list (cons "MT_RUN_AREA_HOME" apath))
|
|
|
|
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
|
(file-name (pathname-strip-directory fname))
(curr-mtcfgdat (find-config "megatest.config"
toppath: (or (get-environment-variable "MT_RUN_AREA_HOME")(current-directory))))
(curr-mtcfg (if (and curr-mtcfgdat (not (null? curr-mtcfgdat)))(cadr curr-mtcfgdat) #f))
(curr-mtpath (if curr-mtcfg (car curr-mtcfgdat) #f)))
(if curr-mtpath
(begin
(debug:print-info 0 *default-log-port* "Creating config file " fname)
(if (not (file-exists? dirname))
(create-directory dirname #t))
(with-output-to-file fname
(lambda ()
(let ((aname (pathname-strip-directory curr-mtpath)))
(print "[" aname "]")
(print "path " curr-mtpath))))
#t)
(begin
(debug:print-info 0 *default-log-port* "Need to create a config but no megatest.config found: " curr-mtcfgdat)
#f))))
;; )
(define (dboard:read-mtconf apath)
(let* ((mtconffile (conc apath "/megatest.config")))
(call-with-environment-variables
(list (cons "MT_RUN_AREA_HOME" apath))
|