~ chicken-core (chicken-5) ef1bee9f0097138ca526fb6c4ab2769265c5b241
commit ef1bee9f0097138ca526fb6c4ab2769265c5b241
Author: Evan Hanson <evhan@foldling.org>
AuthorDate: Wed Aug 9 20:39:03 2017 +1200
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun Aug 13 11:53:22 2017 +0200
Move call chain procedures out of (chicken condition)
Call chains are a general feature not specifically related to
conditions, so we move this back out into the bare "chicken" module.
Eventually these will be moved into "chicken.base" (once it exists).
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/chicken.condition.import.scm b/chicken.condition.import.scm
index 6f669be7..6ab6ce8b 100644
--- a/chicken.condition.import.scm
+++ b/chicken.condition.import.scm
@@ -29,8 +29,6 @@
'((abort . chicken.condition#abort)
(signal . chicken.condition#signal)
(current-exception-handler . chicken.condition#current-exception-handler)
- (get-call-chain . chicken.condition#get-call-chain)
- (print-call-chain . chicken.condition#print-call-chain)
(print-error-message . chicken.condition#print-error-message)
(with-exception-handler . chicken.condition#with-exception-handler)
(make-property-condition . chicken.condition#make-property-condition)
diff --git a/chicken.import.scm b/chicken.import.scm
index c81b8304..a812d0d9 100644
--- a/chicken.import.scm
+++ b/chicken.import.scm
@@ -109,7 +109,7 @@
(fxxor . chicken.fixnum#fxxor)
(fxlen . chicken.fixnum#fxlen)
gensym
- (get-call-chain . chicken.condition#get-call-chain)
+ get-call-chain
(get-condition-property . chicken.condition#get-condition-property)
get-environment-variable
(get-line-number . chicken.syntax#get-line-number)
@@ -147,7 +147,7 @@
(provide . chicken.load#provide)
(provided? . chicken.load#provided?)
print
- (print-call-chain . chicken.condition#print-call-chain)
+ print-call-chain
print*
procedure-information
program-name
diff --git a/library.scm b/library.scm
index 99c32b7a..07bebe1f 100644
--- a/library.scm
+++ b/library.scm
@@ -4380,6 +4380,70 @@ EOF
(string-append "#<pointer 0x" (##sys#number->string (##sys#pointer->address x) 16) ">") ) ) ) )
+;;; Access backtrace:
+
+(define-constant +trace-buffer-entry-slot-count+ 4)
+
+(define get-call-chain
+ (let ((extract
+ (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
+ (c +trace-buffer-entry-slot-count+)
+ (vec (##sys#make-vector (fx* c tbl) #f))
+ (r (##core#inline "C_fetch_trace" start vec))
+ (n (if (fixnum? r) r (fx* c tbl))))
+ (let loop ((i 0))
+ (if (fx>= i n)
+ '()
+ (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
+ (##sys#slot vec (fx+ i 1)) ; cooked1
+ (##sys#slot vec (fx+ i 2))) ; cooked2
+ (loop (fx+ i c)))
+ (loop (fx+ i c))))))))))
+
+(define (##sys#really-print-call-chain port chain header)
+ (when (pair? chain)
+ (##sys#print header #f port)
+ (for-each
+ (lambda (info)
+ (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 " #f port)
+ (when (and more2 (if fi (##sys#slot more2 1)))
+ (##sys#write-char-0 #\[ port)
+ (##sys#print
+ (if fi
+ (##sys#slot more2 1) ; cntr
+ more2)
+ #f port)
+ (##sys#print "] " #f port))
+ (when more1
+ (##sys#with-print-length-limit
+ 100
+ (lambda ()
+ (##sys#print more1 #t port))))))
+ chain)
+ (##sys#print "\t<--\n" #f port)))
+
+(define (print-call-chain #!optional (port ##sys#standard-output) (start 0)
+ (thread ##sys#current-thread)
+ (header "\n\tCall history:\n"))
+ (##sys#check-output-port port #t 'print-call-chain)
+ (##sys#check-fixnum start 'print-call-chain)
+ (##sys#check-string header 'print-call-chain)
+ (let ((ct (get-call-chain start thread)))
+ (##sys#really-print-call-chain port ct header)
+ ct))
+
+
;;; Interrupt handling:
(define (##sys#user-interrupt-hook)
@@ -4447,8 +4511,8 @@ EOF
(module chicken.condition
;; NOTE: We don't emit the import lib. Due to syntax exports, it
;; has to be a hardcoded primitive module.
- (abort signal current-exception-handler get-call-chain
- print-call-chain print-error-message with-exception-handler
+ (abort signal current-exception-handler
+ print-error-message with-exception-handler
;; [syntax] condition-case handle-exceptions
@@ -4460,71 +4524,9 @@ EOF
(import scheme)
(import chicken.fixnum)
(import chicken.foreign)
-(import (only chicken get-output-string open-output-string when unless
- define-constant fixnum? let-optionals make-parameter))
-
-;;; Access backtrace:
-
-(define-constant +trace-buffer-entry-slot-count+ 4)
-
-(define get-call-chain
- (let ((extract
- (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
- (c +trace-buffer-entry-slot-count+)
- (vec (##sys#make-vector (fx* c tbl) #f))
- (r (##core#inline "C_fetch_trace" start vec))
- (n (if (fixnum? r) r (fx* c tbl))))
- (let loop ((i 0))
- (if (fx>= i n)
- '()
- (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
- (##sys#slot vec (fx+ i 1)) ; cooked1
- (##sys#slot vec (fx+ i 2))) ; cooked2
- (loop (fx+ i c)))
- (loop (fx+ i c))))))))))
-
-(define (##sys#really-print-call-chain port chain header)
- (when (pair? chain)
- (##sys#print header #f port)
- (for-each
- (lambda (info)
- (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 " #f port)
- (when (and more2 (if fi (##sys#slot more2 1)))
- (##sys#write-char-0 #\[ port)
- (##sys#print
- (if fi
- (##sys#slot more2 1) ; cntr
- more2)
- #f port)
- (##sys#print "] " #f port))
- (when more1
- (##sys#with-print-length-limit
- 100
- (lambda ()
- (##sys#print more1 #t port))))))
- chain)
- (##sys#print "\t<--\n" #f port)))
-
-(define (print-call-chain #!optional (port ##sys#standard-output) (start 0)
- (thread ##sys#current-thread)
- (header "\n\tCall history:\n"))
- (##sys#check-output-port port #t 'print-call-chain)
- (##sys#check-fixnum start 'print-call-chain)
- (##sys#check-string header 'print-call-chain)
- (let ((ct (get-call-chain start thread)))
- (##sys#really-print-call-chain port ct header)
- ct))
+(import (only chicken get-call-chain print-call-chain when unless
+ get-output-string open-output-string let-optionals
+ make-parameter))
(define (##sys#signal-hook mode msg . args)
(##core#inline "C_dbg_hook" #f)
diff --git a/types.db b/types.db
index 9ac85708..e62c82db 100644
--- a/types.db
+++ b/types.db
@@ -965,7 +965,6 @@
(let ((#(tmp2) (set! ##sys#current-exception-handler #(tmp1))))
#(tmp1))))
(() ##sys#current-exception-handler))
-(chicken.condition#get-call-chain (#(procedure #:clean #:enforce) chicken.condition#get-call-chain (#!optional fixnum (struct thread)) (list-of vector)))
(chicken.condition#get-condition-property (#(procedure #:clean #:enforce) chicken.condition#get-condition-property ((struct condition) * * #!optional *) *))
(chicken.condition#make-composite-condition (#(procedure #:clean #:enforce) chicken.condition#make-composite-condition (#!rest (struct condition)) (struct condition)))
(chicken.condition#make-property-condition (#(procedure #:clean #:enforce) chicken.condition#make-property-condition (* #!rest *) (struct condition)))
@@ -1281,8 +1280,10 @@
(port-closed? (#(procedure #:clean #:enforce) port-closed? (port) boolean)
((port) (eq? (##sys#slot #(1) '8) '0)))
-(print (procedure print (#!rest *) undefined))
+(get-call-chain (#(procedure #:clean #:enforce) get-call-chain (#!optional fixnum (struct thread)) (list-of vector)))
(print-call-chain (#(procedure #:clean #:enforce) print-call-chain (#!optional output-port fixnum * string) undefined))
+
+(print (procedure print (#!rest *) undefined))
(print* (procedure print* (#!rest) undefined))
(procedure-information (#(procedure #:clean #:enforce) procedure-information (procedure) *))
(program-name (#(procedure #:clean #:enforce) program-name (#!optional string) string))
Trap