191 lines
7.1 KiB
Plaintext
191 lines
7.1 KiB
Plaintext
;******************************************************************************
|
|
;
|
|
; Project : STk-inspect, a graphical debugger for STk
|
|
;
|
|
; File name : inspect-main.stk
|
|
; Creation date : Aug-10-1993
|
|
; Last update : Sep-17-1993
|
|
;
|
|
;******************************************************************************
|
|
;
|
|
; This file implements the "General inspector".
|
|
;
|
|
;******************************************************************************
|
|
|
|
(provide "inspect-main")
|
|
(require "inspect-misc")
|
|
(require "inspect-view")
|
|
(require "inspect-detail")
|
|
(require "inspect-help")
|
|
|
|
(define INSPECTOR_WIDGET_NAME ".inspector")
|
|
(define inspected-objects-list ())
|
|
|
|
(define (inspected? obj) (member obj inspected-objects-list))
|
|
|
|
(define (inspect-frame-wid obj)
|
|
(widget INSPECTOR_WIDGET_NAME ".f1." (object-symbol obj)))
|
|
(define (inspect-frame-str obj)
|
|
(& INSPECTOR_WIDGET_NAME ".f1." (object-symbol obj)))
|
|
|
|
(define (inspect-l-wid obj) (widget (inspect-frame-str obj) ".l"))
|
|
(define (inspect-l-str obj) (& (inspect-frame-str obj) ".l"))
|
|
(define (inspect-e-wid obj) (widget (inspect-frame-str obj) ".e"))
|
|
(define (inspect-e-str obj) (& (inspect-frame-str obj) ".e"))
|
|
(define (inspect-mb-wid obj) (widget (inspect-frame-str obj) ".mb"))
|
|
(define (inspect-mb-str obj) (& (inspect-frame-str obj) ".mb"))
|
|
(define (inspect-m-str obj) (& (inspect-frame-str obj) ".mb.m"))
|
|
(define (inspect-m-wid obj) (widget (inspect-frame-str obj) ".mb.m"))
|
|
|
|
|
|
;---- Inspector menu
|
|
|
|
(define (create-inspect-menu obj)
|
|
(define w (eval [menu (inspect-m-str obj)]))
|
|
(w 'add 'command :label "Uninspect"
|
|
:command `(inspect-menu-Uninspect ',(object-symbol obj)))
|
|
(w 'add 'command :label "Detail"
|
|
:command `(inspect-menu-Detail ',(object-symbol obj)))
|
|
(if (detailed? obj) ((inspect-m-wid obj) 'disable "Detail"))
|
|
(w 'add 'command :label "View"
|
|
:command `(inspect-menu-View ',(object-symbol obj)))
|
|
(if (viewed? obj) ((inspect-m-wid obj) 'disable "View")))
|
|
|
|
(define (inspect-menu-Eval obj)
|
|
(eval-string (format #f "(set! ~a ~a)" obj ((inspect-e-wid obj) 'get))))
|
|
|
|
(define (inspect-menu-Quote obj)
|
|
(eval-string (format #f "(set! ~a '~a)" obj ((inspect-e-wid obj) 'get))))
|
|
|
|
(define (inspect-menu-Uninspect key)
|
|
(uninspect (find-object-infos key)))
|
|
|
|
(define (inspect-menu-Detail key)
|
|
(let ((obj (find-object-infos key)))
|
|
(detail obj)
|
|
((inspect-m-wid obj) 'disable "Detail")
|
|
(if (viewed? obj) ((view-m-wid obj) 'disable "Detail"))))
|
|
|
|
(define (inspect-menu-View key)
|
|
(let ((obj (find-object-infos key)))
|
|
(view obj)
|
|
((inspect-m-wid obj) 'disable "View")
|
|
(if (detailed? obj) ((detail-m-wid obj) 'disable "View"))))
|
|
|
|
(define (create-inspector)
|
|
(define w [toplevel INSPECTOR_WIDGET_NAME])
|
|
(wm 'title w "General inspector")
|
|
(wm 'maxsize w SCREEN_WIDTH SCREEN_HEIGHT)
|
|
(define menu-w (create-menu-widget (& INSPECTOR_WIDGET_NAME ".menu")))
|
|
(pack menu-w :side "top" :fill "x" :padx 4 :pady 2)
|
|
((widget menu-w ".help.m") 'add 'command :label "General inspector"
|
|
:command '(stk:make-help General-Inspector-help))
|
|
(pack [menubutton (& INSPECTOR_WIDGET_NAME ".menu.command") :text "Command"]
|
|
:side "left")
|
|
(define cmd-w (eval [menu (& INSPECTOR_WIDGET_NAME ".menu.command.m")]))
|
|
(cmd-w 'add 'command :label "Uninspect all" :command '(destroy-inspector))
|
|
(cmd-w 'add 'command :label "Undebug" :command '(undebug))
|
|
(tk-set! (widget INSPECTOR_WIDGET_NAME ".menu.command") :menu cmd-w)
|
|
(pack [frame (& INSPECTOR_WIDGET_NAME ".caption")]
|
|
:side "top" :fill "x" :padx 4)
|
|
(pack [label (& INSPECTOR_WIDGET_NAME ".caption.l1")
|
|
:text "Objects" :width 20]
|
|
:side "left")
|
|
(pack [label (& INSPECTOR_WIDGET_NAME ".caption.l2")
|
|
:text "Values" :width 40]
|
|
:side "left" :padx 4)
|
|
(pack [frame (& INSPECTOR_WIDGET_NAME ".f1")]
|
|
:fill "both" :expand "yes" :padx 4 :pady 2))
|
|
|
|
|
|
(define (destroy-inspector)
|
|
(for-each uninspect-object inspected-objects-list))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; inspect
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (inspect obj)
|
|
(when (= (winfo 'exist INSPECTOR_WIDGET_NAME) 0) (create-inspector))
|
|
;; Kludge to avoid problems . Should be modified [eg]
|
|
(let ((obj-val (inspect::eval obj)))
|
|
(when (eqv? (inspect::typeof obj-val) 'widget)
|
|
(set! obj obj-val)))
|
|
|
|
(unless (inspected? obj)
|
|
(inspect-object obj)
|
|
(let ((obj-val (format #f "~S" (inspect::eval obj))))
|
|
(pack [frame (inspect-frame-str obj)] :side "top" :fill "x")
|
|
(pack [menubutton (inspect-mb-str obj)
|
|
:relief "raised" :bd 2 :bitmap BITMAP_MENU]
|
|
:side "right")
|
|
(pack [label (inspect-l-str obj) :relief "groove" :bd 2
|
|
:anchor "w" :text (format #f "~S" obj)
|
|
:width 20 :font MEDIUM_FONT]
|
|
:side "left")
|
|
(pack [entry (inspect-e-str obj) :relief "sunken" :bd 2 :width 40]
|
|
:fill "x" :expand "yes" :padx 4)
|
|
(create-inspect-menu obj)
|
|
(tk-set! (inspect-mb-wid obj) :menu (inspect-m-wid obj))
|
|
|
|
(let ((E (inspect-e-wid obj)))
|
|
(E 'insert 0 obj-val)
|
|
|
|
;; If obj is a symbol, lets the entry modifiable. Otherwise let it as is
|
|
(if (modifiable-object? obj)
|
|
[begin
|
|
(bind E "<Return>" `(inspect-menu-Eval ',obj))
|
|
(bind E "<Shift-Return>" `(inspect-menu-Quote ',obj))]
|
|
[inspect::shadow-entry E]))))
|
|
|
|
;; Destroy Event -> set the list of inspected object to '()
|
|
(bind INSPECTOR_WIDGET_NAME "<Destroy>" '(set! inspected-objects-list '()))
|
|
|
|
;; Allow resizing only in width
|
|
(update 'idletasks)
|
|
(let ((req-h (winfo 'reqheight INSPECTOR_WIDGET_NAME)))
|
|
(wm 'minsize INSPECTOR_WIDGET_NAME 0 req-h)
|
|
(wm 'maxsize INSPECTOR_WIDGET_NAME SCREEN_WIDTH req-h)
|
|
(wm 'geometry INSPECTOR_WIDGET_NAME
|
|
(& (winfo 'width INSPECTOR_WIDGET_NAME) "x" req-h))))
|
|
|
|
(define (inspect-object obj)
|
|
(set! inspected-objects-list (cons obj inspected-objects-list))
|
|
(unless (object-infos obj)
|
|
(add-object-infos obj)
|
|
(if (symbol? obj) (trace-var obj `(update-object ',obj)))))
|
|
|
|
(define (inspect-display obj)
|
|
(let ((entry-w (inspect-e-wid obj)))
|
|
(entry-w 'delete 0 'end)
|
|
(entry-w 'insert 0 (->object (eval obj)))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; uninspect
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (uninspect obj)
|
|
(when (inspected? obj) (uninspect-object obj))
|
|
(update 'idletasks)
|
|
(when (= (winfo 'exist INSPECTOR_WIDGET_NAME) 1)
|
|
(let ((req-h (winfo 'reqheight INSPECTOR_WIDGET_NAME)))
|
|
(wm 'minsize INSPECTOR_WIDGET_NAME 0 req-h)
|
|
(wm 'maxsize INSPECTOR_WIDGET_NAME SCREEN_WIDTH req-h)
|
|
(wm 'geometry INSPECTOR_WIDGET_NAME
|
|
(& (winfo 'width INSPECTOR_WIDGET_NAME) "x" req-h)))))
|
|
|
|
|
|
(define (uninspect-object obj)
|
|
(set! inspected-objects-list (list-remove obj inspected-objects-list))
|
|
(destroy (inspect-frame-wid obj))
|
|
(when (null? inspected-objects-list) (destroy INSPECTOR_WIDGET_NAME))
|
|
(if (detailed? obj) ((detail-m-wid obj) 'enable "Inspect"))
|
|
(if (viewed? obj) ((view-m-wid obj) 'enable "Inspect"))
|
|
(unless (or (detailed? obj) (viewed? obj))
|
|
(remove-object-infos obj)
|
|
(if (symbol? obj) (untrace-var obj))))
|