~ chicken-core (chicken-5) c752a153c006d6ef9854b37c96807d0d91a0903b

commit c752a153c006d6ef9854b37c96807d0d91a0903b
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Jul 14 22:11:17 2010 +0200
Commit:     felix <felix@call-with-current-continuation.org>
CommitDate: Wed Jul 14 22:11:17 2010 +0200

    assert shows line-number information, if available (suggested by Alejandro Forero Cuervo)

diff --git a/chicken-syntax.scm b/chicken-syntax.scm
index 80a1fe63..088e1178 100644
--- a/chicken-syntax.scm
+++ b/chicken-syntax.scm
@@ -149,20 +149,26 @@
 (##sys#extend-macro-environment
  'assert '()
  (##sys#er-transformer
-  (lambda (form r c)
-    (##sys#check-syntax 'assert form '#(_ 1))
-    (let* ((exp (cadr form))
-	   (msg-and-args (cddr form))
-	   (msg (if (eq? '() msg-and-args)
-		    `(##core#immutable '"assertion failed")
-		    (car msg-and-args) ) ) )
-      `(##core#if (##core#check ,exp)
-		  (##core#undefined)
-		  (##sys#error 
-		   ,msg 
-		   ,@(if (fx> (length msg-and-args) 1)
-			 (cdr msg-and-args)
-			 `((##core#quote ,(##sys#strip-syntax exp))))))))))
+  (let ((string-append string-append)
+	(get-line-number get-line-number))
+    (lambda (form r c)
+      (##sys#check-syntax 'assert form '#(_ 1))
+      (let* ((exp (cadr form))
+	     (ln (get-line-number form))
+	     (msg-and-args (cddr form))
+	     (msg  (if (null? msg-and-args)
+		       "assertion failed"
+		       (car msg-and-args)))
+	     (msg (if ln
+		      (string-append "(" ln ") " msg)
+		      msg)))
+	`(##core#if (##core#check ,exp)
+		    (##core#undefined)
+		    (##sys#error 
+		     ,msg 
+		     ,@(if (fx> (length msg-and-args) 1)
+			   (cdr msg-and-args)
+			   `((##core#quote ,(##sys#strip-syntax exp)))))))))))
 
 (##sys#extend-macro-environment
  'ensure
diff --git a/eval.scm b/eval.scm
index 5655070d..f5d4e322 100644
--- a/eval.scm
+++ b/eval.scm
@@ -891,7 +891,11 @@
 	(or (and fname
 		 (or (##sys#dload (##sys#make-c-string fname 'load) topentry #t) 
 		     (and (not (has-sep? fname))
-			  (##sys#dload (##sys#make-c-string (##sys#string-append "./" fname) 'load) topentry #t) ) ) )
+			  (##sys#dload 
+			   (##sys#make-c-string
+			    (##sys#string-append "./" fname) 
+			    'load) 
+			   topentry #t) ) ) )
 	    (call-with-current-continuation
 	     (lambda (abrt)
 	       (fluid-let ((##sys#read-error-with-line-number #t)
diff --git a/library.scm b/library.scm
index 7a3be610..c166abeb 100644
--- a/library.scm
+++ b/library.scm
@@ -3354,23 +3354,29 @@ EOF
 
 ;;; Access backtrace:
 
+(define-constant +trace-buffer-entry-slot-count+ 4)
+
 (define ##sys#get-call-chain
-  (let ((extract (foreign-lambda* nonnull-c-string ((scheme-object x)) "return((C_char *)x);")))
+  (let ((extract
+	 (foreign-lambda* nonnull-c-string ((scheme-object x)) "return((C_char *)x);")))
     (lambda (#!optional (start 0) (thread ##sys#current-thread))
       (let* ((tbl (foreign-value "C_trace_buffer_size" int))
-	     (vec (##sys#make-vector (fx* 4 tbl) #f))
+	     ;; 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* 4 tbl))) )
+	     (n (if (fixnum? r) r (fx* c tbl))) )
 	(let loop ((i 0))
 	  (if (fx>= i n) 
 	      '()
 	      (let ((t (##sys#slot vec (fx+ i 3))))
 		(if (or (not t) (not thread) (eq? thread t))
-		    (cons (vector (extract (##sys#slot vec i))
-				  (##sys#slot vec (fx+ i 1))
-				  (##sys#slot vec (fx+ i 2)) )
-			  (loop (fx+ i 4)) )
-		    (loop (fx+ i 4))) ) ) ) ) ) ) )
+		    (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)
diff --git a/manual/Unit expand b/manual/Unit expand
index 7f863b33..61fbceba 100644
--- a/manual/Unit expand	
+++ b/manual/Unit expand	
@@ -14,10 +14,11 @@ option.
 <procedure>(get-line-number EXPR)</procedure>
 
 If {{EXPR}} is a pair with the car being a symbol, and line-number
-information is available for this expression, then this procedure returns
-the associated line number. If line-number information is not available,
-then {{#f}} is returned.  Note that line-number information for
-expressions is only available in the compiler.
+information is available for this expression, then this procedure
+returns the associated source file and line number as a string. If
+line-number information is not available, then {{#f}} is returned.
+Note that line-number information for expressions is only available in
+the compiler.
 
 ==== expand
 
diff --git a/runtime.c b/runtime.c
index b6e2c46b..4de9bdd2 100644
--- a/runtime.c
+++ b/runtime.c
@@ -184,12 +184,12 @@ extern void _C_do_apply_hack(void *proc, C_word *args, int count) C_noret;
 # define ALIGNMENT_HOLE_MARKER         ((C_word)0xfffffffffffffffeL)
 # define FORWARDING_BIT_SHIFT          63
 # define UWORD_FORMAT_STRING           "0x%016x"
-# define UWORD_COUNT_FORMAT_STRING     "%ud"
+# define UWORD_COUNT_FORMAT_STRING     "%u"
 #else
 # define ALIGNMENT_HOLE_MARKER         ((C_word)0xfffffffe)
 # define FORWARDING_BIT_SHIFT          31
 # define UWORD_FORMAT_STRING           "0x%08x"
-# define UWORD_COUNT_FORMAT_STRING     "%ud"
+# define UWORD_COUNT_FORMAT_STRING     "%u"
 #endif
 
 #define GC_MINOR           0
@@ -3721,6 +3721,8 @@ C_word C_fetch_trace(C_word starti, C_word buffer)
 
       /* outside-pointer, will be ignored by GC */
       C_mutate(&C_block_item(buffer, p++), (C_word)ptr->raw);
+
+      /* subject to GC */
       C_mutate(&C_block_item(buffer, p++), ptr->cooked1);
       C_mutate(&C_block_item(buffer, p++), ptr->cooked2);
       C_mutate(&C_block_item(buffer, p++), ptr->thread);