profile.scm

(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))
		   (expr (cddr data)))
	      (let ((key (car data))
		    (count (cadr data))
		    (file (pair-filename expr))
		    (line (pair-line-number expr)))
		(if (> (ash key -20) 0)
		    (format *stderr* "~A[~A]: ~A~30T~A~%" 
			    file line count
			    (let ((val (object->string expr)))
			      (if (> (length val) 60)
				  (string-append (substring val 0 56) " ...")
				  val)))))))))))

#|
(define old-version s7-version)
(define (s7-version)
  (show-profile)
  (old-version))
|#