>From 7f41f1d5b93b9cf4c0270d0e6b36ab30df77528a Mon Sep 17 00:00:00 2001
From: Evan Hanson <address@hidden>
Date: Wed, 9 Aug 2017 20:39:03 +1200
Subject: [PATCH] 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).
---
 chicken.condition.import.scm |   2 -
 chicken.import.scm           |   4 +-
 library.scm                  | 136 ++++++++++++++++++++++---------------------
 types.db                     |   5 +-
 4 files changed, 74 insertions(+), 73 deletions(-)

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))
-- 
2.11.0