Imported Upstream version 16.5~dfsg

1 files changed, 30 insertions, 0 deletions

diff --git a/profile.scm b/profile.scm
new file mode 100644
index 0000000..614ae0b
--- /dev/null
+++ b/profile.scm
@@ -0,0 +1,30 @@
+(define* (show-profile (n 100))
+  (let ((info (*s7* 'profile-info)))
+    (if (null? info)
+	(format *stderr* "no profiling data!~%")
+	(let ((vect (make-vector (hash-table-entries info))))
+	  (copy info vect)
+	  (set! vect (sort! vect (lambda (a b) (> (cadr a) (cadr b)))))
+	  (set! n (min n (length vect)))
+	  (do ((i 0 (+ i 1)))
+	      ((= i n) (newline *stderr*))
+	    (let* ((data (vect i))
+		   (key (car data))
+		   (count (cadr data))
+		   (expr (cddr data))
+		   (file (pair-filename expr))
+		   (line (pair-line-number expr)))
+	      (if (> (ash key -20) 0)
+		  (format *stderr* "~A[~A]: ~A~40T~A~%" 
+			  file line count
+			  (let ((val (object->string expr)))
+			    (if (> (length val) 40)
+				(string-append (substring val 0 36) " ...")
+				val))))))))))
+
+#|
+(define old-version s7-version)
+(define (s7-version)
+  (show-profile)
+  (old-version))
+|#