~ chicken-core (chicken-5) a9a85ccc66de763fdde1cc40aa877badaef7d19d
commit a9a85ccc66de763fdde1cc40aa877badaef7d19d
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Jul 16 01:19:55 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Jul 16 01:19:55 2010 +0200
##sys#eval-debug-level turned into parameter; eval-frameinfo stored in trace buffer
diff --git a/csi.scm b/csi.scm
index 1a3dab84..5f2122b7 100644
--- a/csi.scm
+++ b/csi.scm
@@ -832,7 +832,7 @@ EOF
((eof-object? x))
(rec (receive (eval x))) ) ) )
(when quietflag
- (set! ##sys#eval-debug-level 0))
+ (##sys#eval-debug-level 0)) ;???
(when (member* '("-h" "-help" "--help") args)
(print-usage)
(exit 0) )
diff --git a/eval.scm b/eval.scm
index f5d4e322..93068b88 100644
--- a/eval.scm
+++ b/eval.scm
@@ -177,8 +177,8 @@
p) ) )
(define ##sys#unbound-in-eval #f)
-(define ##sys#eval-debug-level 1)
(define ##sys#unsafe-eval #f)
+(define ##sys#eval-debug-level (make-parameter 1))
(define ##sys#compile-to-closure
(let ([write write]
@@ -214,13 +214,21 @@
((eq? x (##sys#slot lst 0)) i)
(else (loop (##sys#slot lst 1) (fx+ i 1))) ) ) )
- (define (emit-trace-info tf info cntr)
+ (define (emit-trace-info tf info cntr e v)
(when tf
- (##core#inline "C_emit_eval_trace_info" info cntr ##sys#current-thread) ) )
-
+ (##core#inline
+ "C_emit_eval_trace_info"
+ info
+ (##sys#make-structure 'frameinfo cntr e v)
+ ##sys#current-thread) ) )
+
(define (emit-syntax-trace-info tf info cntr)
(when tf
- (##core#inline "C_emit_syntax_trace_info" info cntr ##sys#current-thread) ) )
+ (##core#inline
+ "C_emit_syntax_trace_info"
+ info
+ cntr
+ ##sys#current-thread) ) )
(define (decorate p ll h cntr)
(##sys#eval-decorator p ll h cntr) )
@@ -738,36 +746,36 @@
(case argc
[(#f) (##sys#syntax-error/context "malformed expression" x)]
[(0) (lambda (v)
- (emit-trace-info tf info cntr)
+ (emit-trace-info tf info cntr e v)
((##core#app fn v)))]
[(1) (let ([a1 (compile (##sys#slot args 0) e #f tf cntr se)])
(lambda (v)
- (emit-trace-info tf info cntr)
+ (emit-trace-info tf info cntr e v)
((##core#app fn v) (##core#app a1 v))) ) ]
[(2) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
[a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)] )
(lambda (v)
- (emit-trace-info tf info cntr)
+ (emit-trace-info tf info cntr e v)
((##core#app fn v) (##core#app a1 v) (##core#app a2 v))) ) ]
[(3) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
[a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]
[a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se)] )
(lambda (v)
- (emit-trace-info tf info cntr)
+ (emit-trace-info tf info cntr e v)
((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v))) ) ]
[(4) (let* ([a1 (compile (##sys#slot args 0) e #f tf cntr se)]
[a2 (compile (##core#inline "C_u_i_list_ref" args 1) e #f tf cntr se)]
[a3 (compile (##core#inline "C_u_i_list_ref" args 2) e #f tf cntr se)]
[a4 (compile (##core#inline "C_u_i_list_ref" args 3) e #f tf cntr se)] )
(lambda (v)
- (emit-trace-info tf info cntr)
+ (emit-trace-info tf info cntr e v)
((##core#app fn v) (##core#app a1 v) (##core#app a2 v) (##core#app a3 v) (##core#app a4 v))) ) ]
[else (let ([as (##sys#map (lambda (a) (compile a e #f tf cntr se)) args)])
(lambda (v)
- (emit-trace-info tf info cntr)
+ (emit-trace-info tf info cntr e v)
(apply (##core#app fn v) (##sys#map (lambda (a) (##core#app a v)) as))) ) ] ) ) )
- (compile exp env #f (fx> ##sys#eval-debug-level 0) cntr se) ) ) )
+ (compile exp env #f (fx> (##sys#eval-debug-level) 0) cntr se) ) ) )
(define ##sys#eval-handler
(make-parameter
diff --git a/library.scm b/library.scm
index c166abeb..c0560ce7 100644
--- a/library.scm
+++ b/library.scm
@@ -3358,7 +3358,7 @@ EOF
(define ##sys#get-call-chain
(let ((extract
- (foreign-lambda* nonnull-c-string ((scheme-object x)) "return((C_char *)x);")))
+ (foreign-lambda* nonnull-c-string ((scheme-object x)) "C_return((C_char *)x);")))
(lambda (#!optional (start 0) (thread ##sys#current-thread))
(let* ((tbl (foreign-value "C_trace_buffer_size" int))
;; 4 slots: "raw" string, cooked1, cooked2, thread
@@ -3369,7 +3369,7 @@ EOF
(let loop ((i 0))
(if (fx>= i n)
'()
- (let ((t (##sys#slot vec (fx+ i 3))))
+ (let ((t (##sys#slot vec (fx+ i 3)))) ; thread
(if (or (not t) (not thread) (eq? thread t))
(cons (vector
(extract (##sys#slot vec i)) ; raw
@@ -3383,14 +3383,18 @@ EOF
(##sys#print header #f port)
(for-each
(lambda (info)
- (let ((more1 (##sys#slot info 1))
- (more2 (##sys#slot info 2)) )
+ (let ((more1 (##sys#slot info 1)) ; cooked1 (expr/form)
+ (more2 (##sys#slot info 2)) ) ; cooked2 (frameinfo)
(##sys#print "\n\t" #f port)
- (##sys#print (##sys#slot info 0) #f port)
+ (##sys#print (##sys#slot info 0) #f port) ; raw (mode)
(##sys#print "\t\t" #f port)
(when more2
(##sys#write-char-0 #\[ port)
- (##sys#print more2 #f port)
+ (##sys#print
+ (if (##sys#structure? more2 'frameinfo)
+ (##sys#slot more2 0)
+ more2)
+ #f port)
(##sys#print "] " #f port) )
(when more1
(##sys#with-print-length-limit
Trap