Re: Line number and source file names in stack trace, part 1
And here is the patch:
diff -c STk-4.0.1/Src/read.c STk-4.0.1-debug/Src/read.c
*** STk-4.0.1/Src/read.c Fri Sep 3 14:21:32 1999
--- STk-4.0.1-debug/Src/read.c Sat Jan 1 13:16:29 2000
***************
*** 49,63 ****
}
}
! static SCM read_list(SCM port, char delim, int case_significant)
/* Read a list ended by the `delim' char */
{
! int c;
! SCM tmp;
c = flush_ws(port, "End of file inside list");
if (c == delim) return(NIL);
/* Read the car */
Ungetc(c, port);
tmp = read_rec(port, case_significant);
--- 49,67 ----
}
}
! static SCM read_list(SCM port, char delim, int case_significant,
! int called )
/* Read a list ended by the `delim' char */
{
! int c, dbg_line;
! SCM tmp, dbg_file, dbg_f, dbg_ret;
c = flush_ws(port, "End of file inside list");
if (c == delim) return(NIL);
+ dbg_line = STk_line_counter;
+ dbg_file = STk_current_filename;
+
/* Read the car */
Ungetc(c, port);
tmp = read_rec(port, case_significant);
***************
*** 69,75 ****
if (c != delim) Serror("missing close parenthesis", NIL);
return(tmp);
}
! return(Cons(tmp, read_list(port, delim, case_significant)));
}
static void read_word(SCM port, int c, int case_significant)
--- 73,90 ----
if (c != delim) Serror("missing close parenthesis", NIL);
return(tmp);
}
!
! dbg_ret = Cons(tmp, read_list(port, delim, case_significant, DBG_RECURSIVE));
! /* Avoid (most of) the calls originating from sources irrelevant to
! debugging.
! */
! if ((called == DBG_DIRECT) && (IPORTP(port))) {
! dbg_f = STk_lookup_variable(READ_HOOK, NIL);
! if (STk_procedurep(dbg_f) == Truth)
! Apply(dbg_f, LIST3(dbg_ret, dbg_file, STk_makeinteger(dbg_line)));
! };
! return(dbg_ret);
!
}
static void read_word(SCM port, int c, int case_significant)
***************
*** 259,267 ****
switch (c) {
case '(':
! return(read_list(port, ')', case_significant));
case '[':
! return(read_list(port, ']', case_significant));
case ')':
case ']':
Puts("\nread: unexpected close parenthesis", STk_curr_eport);
--- 274,282 ----
switch (c) {
case '(':
! return(read_list(port, ')', case_significant, DBG_DIRECT));
case '[':
! return(read_list(port, ']', case_significant, DBG_DIRECT));
case ')':
case ']':
Puts("\nread: unexpected close parenthesis", STk_curr_eport);
***************
*** 284,290 ****
case '\\': read_char(port, Getc(port));
return STk_makechar(STk_string2char(STk_tkbuffer));
case '(' : {
! SCM l = read_list(port, ')', case_significant);
return STk_vector(l, STk_llength(l));
}
case '!' : while ((c=Getc(port)) != '\n')
--- 299,306 ----
case '\\': read_char(port, Getc(port));
return STk_makechar(STk_string2char(STk_tkbuffer));
case '(' : {
! SCM l = read_list(port, ')', case_significant,
! DBG_DIRECT);
return STk_vector(l, STk_llength(l));
}
case '!' : while ((c=Getc(port)) != '\n')
diff -c STk-4.0.1/Src/stk.h STk-4.0.1-debug/Src/stk.h
*** STk-4.0.1/Src/stk.h Sat Sep 4 14:11:14 1999
--- STk-4.0.1-debug/Src/stk.h Sat Jan 1 11:47:44 2000
***************
*** 128,133 ****
--- 128,135 ----
#define REPORT_ERROR "report-error"
+ #define READ_HOOK "*read-hook*"
+
#ifdef USE_TK
# include <tk.h>
# define ROOT_WINDOW "*root*" /* Scheme name of main window */
***************
*** 1220,1225 ****
--- 1222,1229 ----
------------------------------------------------------------------------------
*/
SCM STk_readf(SCM port, int case_significant);
+ #define DBG_DIRECT 0
+ #define DBG_RECURSIVE 1
/*
diff -c STk-4.0.1/Src/toplevel.c STk-4.0.1-debug/Src/toplevel.c
*** STk-4.0.1/Src/toplevel.c Fri Sep 3 14:21:32 1999
--- STk-4.0.1-debug/Src/toplevel.c Sat Jan 1 09:58:51 2000
***************
*** 232,237 ****
--- 232,239 ----
STk_define_variable(GC_VERBOSE, Ntruth, NIL);
STk_define_variable(REPORT_ERROR, NIL, NIL);
+ STk_define_variable(READ_HOOK, Ntruth, NIL);
+
/* Initialize standard ports */
STk_init_standard_ports();
Common subdirectories: STk-4.0.1/Lib/Images and STk-4.0.1-debug/Lib/Images
Common subdirectories: STk-4.0.1/Lib/Match and STk-4.0.1-debug/Lib/Match
Common subdirectories: STk-4.0.1/Lib/STk and STk-4.0.1-debug/Lib/STk
diff -c STk-4.0.1/Lib/error.stk STk-4.0.1-debug/Lib/error.stk
*** STk-4.0.1/Lib/error.stk Fri Sep 3 14:21:32 1999
--- STk-4.0.1-debug/Lib/error.stk Sat Jan 1 19:09:39 2000
***************
*** 255,260 ****
--- 255,540 ----
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
+ ;;;; report-error-with-location
+ ;;;;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; Is autoloaded.
+ (define (dbg-track-source)
+ (set! report-error (lambda args (apply STk:report-error-with-location args)))
+ (set! *read-hook* dbg-read-hook))
+
+ ;; *dbg-hash-table* contains (file . line) pairs.
+ (define *dbg-hash-table* (make-hash-table eq?))
+
+ (define (dbg-read-hook the-cons file line)
+ (hash-table-put! *dbg-hash-table* the-cons (cons file line)))
+
+ (define (STk:report-error-with-location 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 "_at_~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 file-info '())
+
+ (define (select-file |W| x y)
+ (let ((index (|W| 'index (format #f "_at_~a,~a" x y))))
+ (when (< index (length file-info))
+ (let* ((fl (list-ref file-info index))
+ (file (car fl))
+ (line (cdr fl))
+ (cmd (format #f "emacsclient --no-wait +~s \"~s\""
+ line file))
+ (status (system cmd)))
+ (if (not (= status 0))
+ (format (current-error-port)
+ "emacsclient failed... has the server started?"))))))
+
+ (define (select-environment |W| x y)
+ (let ((index (|W| 'index (format #f "_at_~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-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)
+ :yscroll (lambda args (apply scroll-y 'set args))))
+
+ (set! scroll-y (scrollbar scroll-y :orient "ver"
+ :command (lambda args (apply lst 'yview args))))
+
+ (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 (listbox '.stackview.f.env
+ :width 18
+ :height 10
+ :font '(Courier -12)
+ :bd 1
+ :yscroll (lambda args (apply .stackview.f.sy 'set args))
+ :relief "raised")
+ :expand #f :fill "y" :side "left")
+
+ (pack (listbox '.stackview.f.lines ; dbg
+ :width 5
+ :height 10
+ :font '(Courier -12)
+ :bd 1
+ :yscroll (lambda args (apply .stackview.f.sy 'set args))
+ :relief "raised")
+ :expand #f :fill "y" :side "left")
+
+ (pack (listbox '.stackview.f.file ; dbg
+ :width 30
+ :height 10
+ :font '(Courier -12)
+ :bd 1
+ :yscroll (lambda args (apply .stackview.f.sy 'set args))
+ :relief "raised")
+ :expand #f :fill "y" :side "left")
+
+ (pack (listbox '.stackview.f.list
+ :width 20
+ :height 10
+ :font '(Courier -12)
+ :bd 1
+ :relief "raised"
+ :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.env 'yview args)
+ (apply .stackview.f.lines 'yview args)
+ (apply .stackview.f.file 'yview 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)))))
+
+ (match-case (hash-table-get *dbg-hash-table*
+ (car stack)
+ '(" " " "))
+ ((and ?both (?file . ?line))
+ (.stackview.f.file 'insert 'end ; dbg
+ (format #f "~A" file))
+ (.stackview.f.lines 'insert 'end ; dbg
+ (format #f "~A" line))
+ (set! file-info (cons both file-info))))
+ )
+ (set! file-info (reverse file-info))
+
+ ;; 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)
+ (bind .stackview.f.lines "<ButtonRelease-1>" select-file)
+
+ ;;;;;;;;;;;;;;;;;;;;
+ ;;;;
+ ;;;; 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
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
diff -c STk-4.0.1/Lib/tk-init.stk STk-4.0.1-debug/Lib/tk-init.stk
*** STk-4.0.1/Lib/tk-init.stk Sun Sep 26 09:02:14 1999
--- STk-4.0.1-debug/Lib/tk-init.stk Sat Jan 1 18:01:46 2000
***************
*** 356,362 ****
(define (tk-set-error-handler!)
! (autoload "error" STk:report-error bgerror))
;=============================================================================
;
--- 356,362 ----
(define (tk-set-error-handler!)
! (autoload "error" STk:report-error bgerror dbg-track-source))
;=============================================================================
;
*** STk-4.0.1/ChangeLog Mon Sep 27 07:46:35 1999
--- STk-4.0.1-debug/ChangeLog Sat Jan 1 19:08:55 2000
***************
*** 1,3 ****
--- 1,33 ----
+ 2000-01-01 michael hohn <hohn_at_emperor.at.home>
+
+ * Lib/tk-init.stk:
+ Adde dbg-track-source to autoloads.
+
+ * Lib/error.stk:
+ Added STk:report-error-with-location and related definitions.
+ ButtonRelease-1 on the line number calls emacsclient with the file
+ and line number.
+
+ * Src/read.c:
+ Added distinction between direct and recursive invocation of
+ read_list() to avoid unnecessary calls to READ_HOOK.
+ Also, only input from file ports is considered for tracking.
+
+ * Src/slib.c (STk_delete_Tcl_child_Interp):
+ No special handling for READ_HOOK.
+
+ * Src/toplevel.c (init_interpreter):
+ Initialize READ_HOOK.
+
+ * Src/stk.h:
+ Added READ_HOOK macro.
+
+ * Src/read.c ((SCM port, char delim, int case_significant)
+ Added more location handling to read_list.
+ READ_HOOK is called with (cons, file, line) arguments.
+ This may need to be sped up by adding a C variable (maybe
+ USE_READ_HOOK).
+
1999-09-27 Erick Gallesio <eg_at_unice.fr>
* Release 4.0.1
Received on Sun Jan 02 2000 - 07:52:37 CET
This archive was generated by hypermail 2.3.0
: Mon Jul 21 2014 - 19:38:59 CEST