~ chicken-core (chicken-5) 4180f098b6109fcbf5d5ddef611017b997befa99
commit 4180f098b6109fcbf5d5ddef611017b997befa99
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jul 16 08:25:32 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Jul 16 08:25:32 2010 +0200
frameinfo handling and commands
diff --git a/csi.scm b/csi.scm
index 5f2122b7..8c03b5ca 100644
--- a/csi.scm
+++ b/csi.scm
@@ -54,6 +54,7 @@ EOF
##sys#windows-platform)
(hide parse-option-string bytevector-data member* canonicalize-args
describer-table dirseparator? circular-list? improper-pairs?
+ show-frameinfo selected-frame select-frame copy-from-frame
findall command-table default-editor) )
@@ -66,6 +67,7 @@ EOF
(set! ##sys#notices-enabled #t)
(define editor-command (make-parameter #f))
+(define selected-frame #f)
(define default-editor
(or (get-environment-variable "EDITOR")
@@ -333,6 +335,14 @@ EOF
" " (read-line)))))
(if (not (zero? r))
(printf "Editor returned with non-zero exit status ~a" r))))
+ ((f)
+ (show-frameinfo selected-frame)
+ (##sys#void))
+ ((nf)
+ (select-frame (read))
+ (##sys#void))
+ ((cf)
+ (copy-from-frame (read)))
((s)
(let* ((str (read-line))
(r (system str)) )
@@ -354,6 +364,9 @@ EOF
,e FILENAME Run external editor
,s TEXT ... Execute shell-command
,exn Describe last exception
+ ,f Show frame information
+ ,nf N Select frame N
+ ,cf NAME Get variable NAME from current frame
,t EXP Evaluate form and print elapsed time
,x EXP Pretty print expanded expression EXP\n")
(##sys#hash-table-for-each
@@ -710,7 +723,109 @@ EOF
(if (and (fx>= c 32) (fx< c 128))
(write-char (integer->char c) out)
(write-char #\. out) ) ) )
- (##sys#write-char-0 #\newline out) ) ) ) )
+ (write-char #\newline out) ) ) ) )
+
+
+;;; Frame-info operations:
+
+(define show-frameinfo
+ (let ((write-char write-char)
+ (newline newline)
+ (display display))
+ (lambda (fn)
+ (define (prin1 x)
+ (##sys#with-print-length-limit
+ 100
+ (lambda ()
+ (##sys#print x #t ##sys#standard-output))))
+ (let* ((ct (or ##sys#repl-recent-call-chain '()))
+ (len (length ct)))
+ (set! selected-frame
+ (or (and (memq fn ct) fn)
+ (and (fx> len 0)
+ (list-ref ct (fx- len 1)))))
+ (do ((ct ct (cdr ct))
+ (i (fx- len 1) (fx- i 1)))
+ ((null? ct))
+ (let* ((info (car ct))
+ (here (eq? selected-frame info))
+ (form (##sys#slot info 1)) ; cooked1 (expr/form)
+ (data (##sys#slot info 2)) ; cooked2 (cntr/frameinfo)
+ (finfo (##sys#structure? data 'frameinfo))
+ (cntr (if finfo (##sys#slot data 1) data))) ; cntr
+ (printf "~a~a:~a\t~a\t "
+ (if here #\* #\space)
+ i
+ (if (and finfo (pair? (##sys#slot data 2))) #\. #\space) ; e
+ (##sys#slot info 0)) ; raw
+ (when cntr (printf "[~a] " cntr))
+ (prin1 form)
+ (newline)
+ (if (and here finfo)
+ (for-each
+ (lambda (e v)
+ (do ((i 0 (fx+ i 1))
+ (be e (cdr be)))
+ ((null? be))
+ (printf " ~s:\t " (car be))
+ (prin1 (##sys#slot v i))
+ (newline)))
+ (##sys#slot data 2) ; e
+ (##sys#slot data 3))))))))) ; v
+
+(define select-frame
+ (let ((display display))
+ (lambda (n)
+ (cond ((or (not (number? n))
+ (not ##sys#repl-recent-call-chain)
+ (fx< n 0)
+ (fx>= n (length ##sys#repl-recent-call-chain)))
+ (display "no such frame\n"))
+ (else
+ (set! selected-frame
+ (list-ref
+ ##sys#repl-recent-call-chain
+ (fx- (length ##sys#repl-recent-call-chain) (fx+ n 1))))
+ (show-frameinfo selected-frame))))))
+
+(define copy-from-frame
+ (let ((display display)
+ (call/cc call/cc))
+ (lambda (name)
+ (let* ((ct (or ##sys#repl-recent-call-chain '()))
+ (len (length ct))
+ (name
+ (cond ((symbol? name) (##sys#slot name 1)) ; name
+ ((string? name) name)
+ (else
+ (display "string or symbol required for `,cf'\n")
+ #f))))
+ (if name
+ (call/cc
+ (lambda (return)
+ (define (fail msg)
+ (display msg)
+ (return (##sys#void)))
+ (do ((ct ct (cdr ct))
+ (i (fx- len 1) (fx- i 1)))
+ ((null? ct) (fail "no environment in frame\n"))
+ (let* ((info (car ct))
+ (here (eq? selected-frame info))
+ (data (##sys#slot info 2)) ; cooked2 (cntr/frameinfo)
+ (finfo (##sys#structure? data 'frameinfo))
+ (cntr (if finfo (##sys#slot data 1) data))) ; cntr
+ (when (and here finfo)
+ (for-each
+ (lambda (e v)
+ (do ((i 0 (fx+ i 1))
+ (be e (cdr be)))
+ ((null? be) (fail "no such variable\n"))
+ (when (string=? name (##sys#slot (car be) 1)) ; name
+ (history-add (list (##sys#slot v i)))
+ (return (##sys#slot v i)))))
+ (##sys#slot data 2) ; e
+ (##sys#slot data 3))))))) ; v
+ (##sys#void))))))
;;; Start interpreting:
diff --git a/eval.scm b/eval.scm
index 93068b88..ff35cfaf 100644
--- a/eval.scm
+++ b/eval.scm
@@ -1474,6 +1474,7 @@
(define ##sys#repl-eval-hook #f)
(define ##sys#repl-print-length-limit #f)
(define ##sys#repl-read-hook #f)
+(define ##sys#repl-recent-call-chain #f)
(define (##sys#repl-print-hook x port)
(##sys#with-print-length-limit ##sys#repl-print-length-limit (cut ##sys#print x #t port))
@@ -1548,7 +1549,8 @@
(begin
(##sys#write-char-0 #\newline ##sys#standard-error)
(write-err args) ) )
- (print-call-chain ##sys#standard-error)
+ (set! ##sys#repl-recent-call-chain
+ (print-call-chain ##sys#standard-error))
(flush-output ##sys#standard-error) ) ) )
(lambda ()
(let loop ()
diff --git a/library.scm b/library.scm
index c0560ce7..a2a36c0c 100644
--- a/library.scm
+++ b/library.scm
@@ -3383,16 +3383,17 @@ EOF
(##sys#print header #f port)
(for-each
(lambda (info)
- (let ((more1 (##sys#slot info 1)) ; cooked1 (expr/form)
- (more2 (##sys#slot info 2)) ) ; cooked2 (frameinfo)
+ (let* ((more1 (##sys#slot info 1)) ; cooked1 (expr/form)
+ (more2 (##sys#slot info 2)) ; cooked2 (cntr/frameinfo)
+ (fi (##sys#structure? more2 'frameinfo)))
(##sys#print "\n\t" #f port)
(##sys#print (##sys#slot info 0) #f port) ; raw (mode)
- (##sys#print "\t\t" #f port)
+ (##sys#print "\t " #f port)
(when more2
(##sys#write-char-0 #\[ port)
(##sys#print
- (if (##sys#structure? more2 'frameinfo)
- (##sys#slot more2 0)
+ (if fi
+ (##sys#slot more2 1) ; cntr
more2)
#f port)
(##sys#print "] " #f port) )
@@ -3410,7 +3411,9 @@ EOF
(##sys#check-port port 'print-call-chain)
(##sys#check-exact start 'print-call-chain)
(##sys#check-string header 'print-call-chain)
- (##sys#really-print-call-chain port (##sys#get-call-chain start thread) header) )
+ (let ((ct (##sys#get-call-chain start thread)))
+ (##sys#really-print-call-chain port ct header)
+ ct))
(define get-call-chain ##sys#get-call-chain)
diff --git a/manual/Using the interpreter b/manual/Using the interpreter
index a71f3643..ccc516ca 100644
--- a/manual/Using the interpreter
+++ b/manual/Using the interpreter
@@ -143,6 +143,12 @@ The toplevel loop understands a number of special commands:
; ,exn : Describes the last exception that occurred and adds it to the result history (it can be accessed using the {{#}} notation).
+; ,f : Show call-trace items of the most recent error
+
+; ,nf N : Select call-trace item with the given number, where the number {{0}} indicates the last item in the trace
+
+; cf NAME : Returns the value of the local variable with the given name (which may be a symbol or string)
+
; ,q : Quit the interpreter.
; ,r : Show system information.
diff --git a/runtime.c b/runtime.c
index cd17c989..c60190f7 100644
--- a/runtime.c
+++ b/runtime.c
@@ -149,7 +149,7 @@ extern void _C_do_apply_hack(void *proc, C_word *args, int count) C_noret;
#define DEFAULT_FORWARDING_TABLE_SIZE 32
#define DEFAULT_LOCATIVE_TABLE_SIZE 32
#define DEFAULT_COLLECTIBLES_SIZE 1024
-#define DEFAULT_TRACE_BUFFER_SIZE 8
+#define DEFAULT_TRACE_BUFFER_SIZE 10
#define MAX_HASH_PREFIX 64
diff --git a/tests/test-finalizers.scm b/tests/test-finalizers.scm
index b9eda52d..512b0991 100644
--- a/tests/test-finalizers.scm
+++ b/tests/test-finalizers.scm
@@ -1,5 +1,7 @@
;;;; test-finalizers.scm
+(##sys#eval-debug-level 0) ; disable keeping trace-buffer with frameinfo
+
(define x (list 1 2 3))
(define y (list 4 5 6))
(define x-f #f)
Trap