320 lines
9.1 KiB
Plaintext
320 lines
9.1 KiB
Plaintext
;******************************************************************************
|
|
;
|
|
; Project : STk-inspect, a graphical debugger for STk
|
|
;
|
|
; File name : inspect-misc.stk
|
|
; Creation date : Aug-30-1993
|
|
; Last update : Sep-17-1993
|
|
;
|
|
;******************************************************************************
|
|
;
|
|
; This file contains definitions often used.
|
|
;
|
|
;******************************************************************************
|
|
|
|
(provide "inspect-misc")
|
|
|
|
(define BITMAP_MENU (& "@" *stk-library* "/Images/menu.bm"))
|
|
(define FIXED_FONT "-adobe-courier-bold-r-*-*-*-140-*-*-*-*-*-*")
|
|
(define MEDIUM_FONT "-adobe-helvetica-medium-r-*-*-*-120-*-*-*-*-*-*")
|
|
(define BOLD_FONT "-adobe-helvetica-bold-r-*-*-*-120-*-*-*-*-*-*")
|
|
(define ITALIC-MEDIUM_FONT "-adobe-helvetica-medium-o-*-*-*-120-*-*-*-*-*-*")
|
|
|
|
(define COURIER_BR14 "-adobe-courier-bold-r-*-*-*-140-*-*-*-*-*-*")
|
|
(define HELVETICA_BR12 "-adobe-helvetica-bold-r-*-*-*-120-*-*-*-*-*-*")
|
|
(define HELVETICA_BO12 "-adobe-helvetica-bold-o-*-*-*-120-*-*-*-*-*-*")
|
|
(define HELVETICA_MR12 "-adobe-helvetica-medium-r-*-*-*-120-*-*-*-*-*-*")
|
|
(define HELVETICA_MO12 "-adobe-helvetica-medium-o-*-*-*-120-*-*-*-*-*-*")
|
|
(define HELVETICA_MO10 "-adobe-helvetica-medium-o-*-*-*-100-*-*-*-*-*-*")
|
|
(define SCREEN_WIDTH (winfo 'vrootwidth *root*))
|
|
(define SCREEN_HEIGHT (winfo 'vrootheight *root*))
|
|
|
|
|
|
;******************************************************************************
|
|
;
|
|
; General definitions and macros extending STk.
|
|
;
|
|
;******************************************************************************
|
|
|
|
;---- A special eval
|
|
(define (inspect::eval x)
|
|
(if (and (symbol? x) (symbol-bound? x)) (eval x) x))
|
|
|
|
;---- Predicates
|
|
|
|
(define-macro (not-equal? x y) `(not (equal? ,x ,y)))
|
|
(define-macro (different? x y) `(not (equal? ,x ,y)))
|
|
|
|
;---- Operators
|
|
|
|
(define-macro (<> x y)
|
|
`(not (= ,x ,y)))
|
|
|
|
;; method to handle "regular" objects
|
|
|
|
(define (inspect::typeof obj)
|
|
(cond ((boolean? obj) 'boolean)
|
|
((list? obj) 'list)
|
|
((pair? obj) 'pair)
|
|
((symbol? obj) 'symbol)
|
|
((number? obj) 'number)
|
|
((char? obj) 'char)
|
|
((string? obj) 'string)
|
|
((vector? obj) 'vector)
|
|
((widget? obj) 'widget) ; must be before since widgets are also closures
|
|
((closure? obj) 'closure)
|
|
((primitive? obj) 'primitive)
|
|
(else 'unknown)))
|
|
|
|
;; method to handle classes
|
|
|
|
;(define-method inspect::typeof ((obj <object>))
|
|
; 'stklos)
|
|
|
|
|
|
;---- Display
|
|
|
|
(define (write\n . l)
|
|
(until (null? l)
|
|
(write (car l))
|
|
(set! l (cdr l)))
|
|
(newline))
|
|
|
|
(define (display\n . l)
|
|
(until (null? l)
|
|
(display (car l))
|
|
(set! l (cdr l)))
|
|
(newline))
|
|
|
|
|
|
;---- Control structures
|
|
|
|
(define-macro (for var test . body)
|
|
`(do ,var
|
|
((not ,test))
|
|
,@body))
|
|
|
|
;---- Strings
|
|
|
|
(define (->string obj)
|
|
(if (widget? obj)
|
|
(widget->string obj)
|
|
(format #f "~A" obj)))
|
|
|
|
(define (->object obj)
|
|
(if (widget? obj)
|
|
(widget->string obj)
|
|
(format #f "~S" obj)))
|
|
|
|
(define (list->str l)
|
|
(if (null? l)
|
|
""
|
|
(let loop ((l l) (s ""))
|
|
(let ((car-l (car l)) (cdr-l (cdr l)) (elem ()))
|
|
(if (list? car-l)
|
|
(set! elem (string-append "(" (list->str car-l) ")"))
|
|
(set! elem (->string car-l)))
|
|
(if (null? cdr-l)
|
|
(string-append s elem)
|
|
(loop cdr-l (string-append s elem " ")))))))
|
|
|
|
;---- Vectors
|
|
|
|
(define (vector-index v value)
|
|
(let ((length (vector-length v))
|
|
(index #f))
|
|
(for ((i (- length 1) (- i 1)))
|
|
(>= i 0)
|
|
(if (equal? (vector-ref v i) value) (set! index i)))
|
|
index))
|
|
|
|
|
|
;---- Lists
|
|
|
|
(define (list-first obj lst)
|
|
(define (_list-first obj lst index)
|
|
(cond ((null? lst) #f)
|
|
((equal? obj (car lst)) index)
|
|
(else (_list-first obj (cdr lst) (+ index 1)))))
|
|
(_list-first obj lst 0))
|
|
|
|
|
|
(define-macro (list-set! lst index value)
|
|
`(begin
|
|
(set! ,lst (list->vector ,lst))
|
|
(vector-set! ,lst ,index ,value)
|
|
(set! ,lst (vector->list ,lst))))
|
|
|
|
|
|
(define (list-remove obj lst)
|
|
(define (_list-remove obj lst prev-lst)
|
|
(cond ((null? lst) prev-lst)
|
|
((equal? obj (car lst)) (append prev-lst (cdr lst)))
|
|
(else (_list-remove obj (cdr lst) (append prev-lst
|
|
(list (car lst)))))))
|
|
(_list-remove obj lst ()))
|
|
|
|
|
|
;---- Tk goodies
|
|
|
|
(define-macro (widget . etc)
|
|
`(string->widget (& ,@etc)))
|
|
|
|
(define (&& . l)
|
|
(if (null? l)
|
|
""
|
|
(let loop ((l l) (s ""))
|
|
(if (null? (cdr l))
|
|
(string-append s (->string (car l)))
|
|
(loop (cdr l) (string-append s (->string (car l)) " "))))))
|
|
|
|
(define-macro (tki-get canvas item option)
|
|
`(list-ref (,canvas 'itemconfigure ,item ,option) 2))
|
|
|
|
(define-macro (tki-set canvas item option value)
|
|
`(,canvas 'itemconfigure ,item ,option ,value))
|
|
|
|
(define-macro (@ x y)
|
|
`(& "@" ,x "," ,y))
|
|
|
|
;******************************************************************************
|
|
;
|
|
;
|
|
;
|
|
;******************************************************************************
|
|
|
|
(define objects-infos-list ())
|
|
|
|
(define (object-infos obj) (assoc obj objects-infos-list))
|
|
|
|
(define (object-type obj) (list-ref (object-infos obj) 1))
|
|
(define (object-symbol obj) (list-ref (object-infos obj) 2))
|
|
|
|
(define (add-object-infos obj)
|
|
(set! objects-infos-list
|
|
(cons (list obj (inspect::typeof obj) (gensym "__g"))
|
|
objects-infos-list)))
|
|
|
|
(define (remove-object-infos obj)
|
|
(set! objects-infos-list
|
|
(list-remove (object-infos obj) objects-infos-list)))
|
|
|
|
(define (find-object-infos key)
|
|
(let ((found #f))
|
|
(do ((l objects-infos-list (cdr l)))
|
|
((or found (null? l)) found)
|
|
(when (equal? (list-ref (car l) 2) key)
|
|
(set! found (list-ref (car l) 0))))))
|
|
|
|
(define (detailer-type obj-type)
|
|
(case obj-type
|
|
((vector pair list) 'VPL)
|
|
((procedure) 'PROCEDURE)
|
|
((widget) 'WIDGET)
|
|
((object) 'STKLOS)
|
|
(else 'UNKNOWN)))
|
|
|
|
(define (viewer-type obj-type)
|
|
(case obj-type
|
|
((procedure) 'PROCEDURE)
|
|
((widget) 'WIDGET)
|
|
(else 'GENERAL)))
|
|
|
|
(define (update-object obj)
|
|
(let* ((obj-val (inspect::eval obj))
|
|
(old-type (object-type obj))
|
|
(obj-type (inspect::typeof obj-val)))
|
|
(unless (equal? old-type obj-type)
|
|
(let ((obj-sym (object-symbol obj)))
|
|
(remove-object-infos obj)
|
|
(set! objects-infos-list
|
|
(cons (list obj obj-type obj-sym) objects-infos-list))))
|
|
(if (inspected? obj) (inspect-display obj))
|
|
(if (detailed? obj)
|
|
(if (equal? (detailer-type old-type) (detailer-type obj-type))
|
|
(detail-display obj)
|
|
(begin
|
|
(undetail obj)
|
|
(if (different? 'UNKNOWN (detailer-type obj-type))
|
|
(detail obj)))))
|
|
(if (viewed? obj)
|
|
(if (equal? (viewer-type old-type) (viewer-type obj-type))
|
|
(view-display obj)
|
|
(begin
|
|
(unview obj)
|
|
(view obj))))
|
|
(update 'idletask)))
|
|
|
|
;---- Undebug
|
|
|
|
(define (undebug)
|
|
(for-each (lambda (obj-infos)
|
|
(let ((obj (car obj-infos)))
|
|
(if (symbol? obj) (untrace-var obj))))
|
|
objects-infos-list)
|
|
(destroy INSPECTOR_WIDGET_NAME)
|
|
(set! inspected-objects-list ())
|
|
(for-each (lambda (obj) (destroy (detail-tl-wid obj))) detailed-objects-list)
|
|
(set! detailed-objects-list ())
|
|
(for-each (lambda (obj) (destroy (view-tl-wid obj))) viewed-objects-list)
|
|
(set! viewed-objects-list ())
|
|
(set! objects-infos-list ()))
|
|
|
|
;---- id widget
|
|
|
|
(define (create-id-widget str)
|
|
(define wid [frame str])
|
|
(pack [frame (& str ".f1")] :side "top" :fill "x")
|
|
(pack [label (& str ".f1.l1") :anchor "w"] :side "left")
|
|
(pack [label (& str ".f1.l2")
|
|
:relief "groove" :bd 2 :anchor "w" :font MEDIUM_FONT]
|
|
:fill "x" :expand "yes")
|
|
(pack [frame (& str ".f2")] :side "top" :fill "x")
|
|
(pack [label (& str ".f2.l") :anchor "w"] :side "left")
|
|
(pack [entry (& str ".f2.e") :relief "sunken" :bd 2]
|
|
:fill "x" :expand "yes")
|
|
wid)
|
|
|
|
(define (set-id-label1 wid text width)
|
|
((widget wid ".f1.l1") 'config :text text :width width))
|
|
(define (set-id-label2 wid text width)
|
|
((widget wid ".f2.l") 'config :text text :width width))
|
|
|
|
(define (set-id-object wid text) (tk-set! (widget wid ".f1.l2") :text text))
|
|
(define (get-id-object wid) (tk-get (widget wid ".f1.l2") :text))
|
|
(define (set-id-value wid text)
|
|
((widget wid ".f2.e") 'delete 0 'end)
|
|
((widget wid ".f2.e") 'insert 0 text))
|
|
(define (get-id-value wid) ((widget wid ".f2.e") 'get))
|
|
|
|
|
|
;---- menu widget
|
|
|
|
(define (create-menu-widget str)
|
|
(define wid [frame str :relief "raised" :bd 2])
|
|
(pack [menubutton (& str ".help") :text "Help"] :side "right")
|
|
(tk-set! (widget str ".help") :menu [menu (& str ".help.m")])
|
|
((widget str ".help.m") 'add 'command :label "STk-inspect"
|
|
:command '(stk:make-help STk-inspect-help))
|
|
wid)
|
|
|
|
|
|
;---- toplevel widget
|
|
|
|
(define (create-toplevel-widget str)
|
|
(define wid [toplevel str])
|
|
(pack (create-id-widget (& str ".id")) :side "top" :fill "x" :padx 4 :pady 2)
|
|
(pack (create-menu-widget (& str ".menu"))
|
|
:side "top" :fill "x" :padx 4 :pady 2)
|
|
wid)
|
|
|
|
(define (inspect::shadow-entry e)
|
|
(tk-set! e :state "disabled")
|
|
(tk-set! e :bd 1)
|
|
(tk-set! e :bg "grey50")
|
|
(tk-set! e :fg "grey95"))
|
|
|
|
|
|
(define (modifiable-object? obj)
|
|
(and (symbol? obj) (symbol-bound? obj) (not (widget? (inspect::eval obj)))))
|