274 lines
8.6 KiB
Plaintext
274 lines
8.6 KiB
Plaintext
;;;;
|
|
;;;; e r r o r . s t k -- All the stuff going with error messages
|
|
;;;; display
|
|
;;;;
|
|
;;;;
|
|
;;;; Copyright © 1993-1999 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
|
|
;;;;
|
|
;;;; Permission to use, copy, modify, distribute,and license this
|
|
;;;; software and its documentation for any purpose is hereby granted,
|
|
;;;; provided that existing copyright notices are retained in all
|
|
;;;; copies and that this notice is included verbatim in any
|
|
;;;; distributions. No written agreement, license, or royalty fee is
|
|
;;;; required for any of the authorized uses.
|
|
;;;; This software is provided ``AS IS'' without express or implied
|
|
;;;; warranty.
|
|
;;;;
|
|
;;;;
|
|
;;;; Author: Erick Gallesio [eg@unice.fr]
|
|
;;;; Creation date: 15-Sep-1993 14:11
|
|
;;;; Last file update: 3-Sep-1999 19:50 (eg)
|
|
;;;;
|
|
|
|
(require "dialog")
|
|
(select-module Tk)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; report-error (this version of report-error needs Tk)
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (STk:report-error head message obj)
|
|
;; Since this function is loaded only when needed the stack is different
|
|
;; on first execution
|
|
(define stack (cddddr (%get-eval-stack)))
|
|
(define env (cddddr (%get-environment-stack)))
|
|
(define current-env (global-environment))
|
|
|
|
(define (truncate s len)
|
|
(if (> (string-length s) len)
|
|
(string-append (substring s 0 (- len 1)) " ...")
|
|
s))
|
|
|
|
(define (adjust-string s len)
|
|
(let ((l (string-length s)))
|
|
(if (>= l len)
|
|
s
|
|
(string-append s (make-string (- len l) #\space)))))
|
|
|
|
(define (local-eval x)
|
|
(eval x current-env))
|
|
|
|
(define (select-expression |W| x y)
|
|
(let ((index (|W| 'index (format #f "@~a,~a" x y))))
|
|
(when (< index (length stack))
|
|
(set! current-env (list-ref env index))
|
|
(listener-insert-string .stackview.vt.l
|
|
(format #f ";; Current environment is ~A\n"
|
|
(if (eq? current-env (global-environment))
|
|
"global environment"
|
|
current-env))))))
|
|
|
|
(define (select-environment |W| x y)
|
|
(let ((index (|W| 'index (format #f "@~a,~a" x y))))
|
|
(display-environment (if (= index (length env))
|
|
(global-environment)
|
|
(list-ref env index)))))
|
|
|
|
(define (display-environment e)
|
|
(let* ((top (gensym ".top_env"))
|
|
(f1 (format #f "~A.f" top))
|
|
(lst (format #f "~A.f.lst" top))
|
|
(scroll-x (format #f "~A.f.sx" top))
|
|
(scroll-y (format #f "~A.f.sy" top))
|
|
(f2 (format #f "~A.b" top))
|
|
(parent (format #f "~A.b.parent" top))
|
|
(quit (format #f "~A.b.quit" top))
|
|
(el (car (environment->list e))))
|
|
|
|
(toplevel top)
|
|
(wm 'title top (format #f "~S" e))
|
|
(pack (frame f1) :expand #t :fill "both" :side "top")
|
|
(pack (frame f2) :expand #f :fill "x" :side "top")
|
|
|
|
;;;;; Listbox and its scrollbar
|
|
(set! lst (listbox lst :width 70 :height (max 2 (min (length el) 20))
|
|
:font '(Courier -12)
|
|
:xscroll (lambda args (apply scroll-x 'set args))
|
|
:yscroll (lambda args (apply scroll-y 'set args))))
|
|
(set! scroll-x (scrollbar scroll-x :orient "hor"
|
|
:command (lambda args (apply lst 'xview args))))
|
|
(set! scroll-y (scrollbar scroll-y :orient "ver"
|
|
:command (lambda args (apply lst 'yview args))))
|
|
|
|
(pack scroll-x :side "bottom" :fill "x")
|
|
(pack lst :expand #t :fill "both" :side "left")
|
|
(pack scroll-y :side "left" :fill "y")
|
|
|
|
;; fill it
|
|
(let ((bindings (map (lambda (x)
|
|
(format #f "~A = ~S"
|
|
(adjust-string (symbol->string (car x)) 20)
|
|
(cdr x)))
|
|
el)))
|
|
(apply lst 'insert 0 (sort bindings string<?)))
|
|
|
|
;; Parent and quit button
|
|
(let ((p (parent-environment e)))
|
|
(pack (button quit
|
|
:text "Quit" :command (lambda () (destroy top)))
|
|
(button parent
|
|
:text "Parent environment"
|
|
:state (if p "normal" "disabled")
|
|
:command (lambda () (display-environment p)))
|
|
:expand #t :fill "x" :side "left"))))
|
|
|
|
|
|
(define (display-stack stack env)
|
|
(catch (destroy ".stackview"))
|
|
|
|
;; Build a toplevel
|
|
(toplevel '.stackview)
|
|
(wm 'title .stackview "STk stack")
|
|
|
|
;; Dispose items
|
|
(pack (label '.stackview.l :text "Stack content" :fg "RoyalBlue")
|
|
:side "top")
|
|
(pack (frame '.stackview.f :bd 3 :relief "groove")
|
|
:side "top" :expand #t :fill "both" :padx 5 :pady 5)
|
|
(pack (frame '.stackview.b)
|
|
:side "bottom" :fill "x")
|
|
|
|
;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; The (double) listbox
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;
|
|
(pack (scrollbar '.stackview.f.sx
|
|
:orient "hor"
|
|
:command (lambda args
|
|
(apply .stackview.f.list 'xview args)))
|
|
:side "bottom" :fill "x")
|
|
|
|
(pack (listbox '.stackview.f.env
|
|
:width 18
|
|
:height 10
|
|
:font '(Courier -12)
|
|
:bd 1
|
|
:relief "raised")
|
|
:expand #f :fill "y" :side "left")
|
|
|
|
(pack (listbox '.stackview.f.list
|
|
:width 70
|
|
:height 10
|
|
:font '(Courier -12)
|
|
:bd 1
|
|
:relief "raised"
|
|
:xscroll (lambda args (apply .stackview.f.sx 'set args))
|
|
:yscroll (lambda args (apply .stackview.f.sy 'set args)))
|
|
:expand #t :fill "both" :side "left")
|
|
|
|
(pack (scrollbar '.stackview.f.sy
|
|
:orient "vert"
|
|
:command (lambda args
|
|
(apply .stackview.f.list 'yview args)))
|
|
:side "left" :fill "y")
|
|
|
|
;; Insert the stack elements in the listbox
|
|
(do ((stack stack (cdr stack))
|
|
(env env (cdr env)))
|
|
((null? stack))
|
|
(.stackview.f.list 'insert 'end
|
|
(truncate (format #f "~S" (uncode(car stack))) 150))
|
|
(.stackview.f.env 'insert 'end
|
|
(format #f "~A"
|
|
(if (equal? (car env) (global-environment))
|
|
"*global*"
|
|
(address-of (car env))))))
|
|
|
|
;; Insert a marker to delimit bottom of the stack
|
|
(.stackview.f.list 'insert 'end "<<< STACK BOTTOM >>>")
|
|
(.stackview.f.env 'insert 'end "*global*")
|
|
|
|
;; listbox bindings
|
|
(bind .stackview.f.env "<ButtonRelease-1>" select-environment)
|
|
(bind .stackview.f.list "<ButtonRelease-1>" select-expression)
|
|
|
|
;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Listener
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;
|
|
(pack (label '.stackview.l2 :text "Listener" :fg "RoyalBlue")
|
|
:side "top")
|
|
|
|
(pack (frame '.stackview.vt :bd 3 :relief "groove")
|
|
:expand #t :fill "both" :padx 5 :pady 5)
|
|
(pack (listener '.stackview.vt.l
|
|
:font '(Courier -12)
|
|
:wrap "word"
|
|
:height 10
|
|
:command (lambda (x) (format #f "~S"
|
|
(eval-string x current-env)))
|
|
:yscroll (lambda args (apply .stackview.vt.s 'set args)))
|
|
:side "left" :expand #t :fill "both")
|
|
(pack (scrollbar '.stackview.vt.s
|
|
:orient "vert"
|
|
:command (lambda args (apply .stackview.vt.l 'yview args)))
|
|
:side "right" :expand #f :fill "y")
|
|
;;;;;;;;;;;;;;;;;;;;
|
|
;;
|
|
;; Bottom buttons
|
|
;;
|
|
;;;;;;;;;;;;;;;;;;;;
|
|
(pack [button '.stackview.b.q
|
|
:text "Quit"
|
|
:command (lambda () (destroy .stackview))]
|
|
[button '.stackview.b.h
|
|
:text "Help"
|
|
:command (lambda ()
|
|
(STk:show-help-file "error-hlp.html"))]
|
|
:side "left" :expand #t :fill "x")
|
|
|
|
;; Center the window
|
|
(STk:center-window .stackview))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Report-error starts here
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
(let* ((who (if (null? obj) "" (format #f "~S" obj)))
|
|
(msg (truncate (string-append head "\n" message "\n" who "\n") 200)))
|
|
|
|
;; Print message on standard error stream
|
|
(format (current-error-port) "\n~A~A~A\n"
|
|
head
|
|
message
|
|
(if (equal? who "") "" (string-append ": " who)))
|
|
|
|
;; Remove grab (if any) to allow interactions in the the next dialog
|
|
(for-each (lambda (x) (grab 'release x)) (winfo 'children *root*))
|
|
|
|
;; Open dialog box
|
|
(stk::make-dialog
|
|
:window '.report-error
|
|
:title "STk error"
|
|
:text msg
|
|
:image (make-image "error.gif")
|
|
:grab #f
|
|
:default 0
|
|
:buttons `((" Quit " ,(lambda () '()))
|
|
("See the stack" ,(lambda ()
|
|
(display-stack stack env)))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;;;;
|
|
;;;; Misc
|
|
;;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define *error-info* "")
|
|
|
|
(define (bgerror . message)
|
|
;; Important note: When a background error occurs, tk try to see if
|
|
;; bgerror is bound to something. This is achieved by calling bgerror
|
|
;; with an empty message. In this case, nothing is printed
|
|
(unless (null? message)
|
|
(format (current-error-port) "**** Tk error (~S) ~S~%"
|
|
(car message) *error-info*))
|
|
(set! *error-info* ""))
|
|
|
|
(define tkerror bgerror) ;; For compatibility with pre-Tk4.1 (i.e STk-3.1)
|