(use advice)

(define (add foo bar)
  (+ foo bar))

(define debug-port (make-parameter (current-error-port)))

(define (debug procedure param)
  (let* ((proc-info (procedure-information procedure))
         (proc-name (or (and proc-info (car proc-info))
                        "unknown procedure"))
         (proc-args (or (and proc-info (cdr proc-info))
                        '())))
    (advise 'before
            procedure
            (lambda (args)
              (let ((arg-pos (list-index
                              (lambda (elt)
                                (eq? elt param))
                              proc-args)))
                (and arg-pos
                     (fprintf (debug-port)
                              "~a (~a): ~S\n"
                              proc-name
                              param
                              (list-ref args arg-pos))))))))

(debug add 'foo)

(add 3 4)
(add 2 5)
(add (lambda () 3) 3)

(define (do-trace procs)
  (for-each
   (lambda (s)
     (ensure procedure? s)
     (cond ((traced? s)
	    (warning "procedure already traced" s) )
	   (else
	    (let ((name (procedure-name s)))
	      (when (trace-verbose)
		(fprintf (current-error-port) "; tracing ~a~%" name))
	      (set! *traced-procedures* (cons (cons s name) *traced-procedures*))
	      (advise 
	       'around s
	       (lambda (next args)
		 (let ((results #f))
		   (dynamic-wind
		       (cut traced-procedure-entry name args)
		       (lambda () 
			 (call-with-values (cut apply next args)
			   (lambda rs
			     (set! results rs)
			     (apply values rs))))
		       (cut traced-procedure-exit name results))))
	       '*trace*)))))
   procs) )

  (define (mutate-procedure old proc)
    (unless (##core#check (procedure? old))
      (##sys#signal-hook #:type-error 'mutate-procedure "bad argument type - not a procedure" old))
    (let* ((n (##sys#size old))
	   (words (##core#inline "C_words" n))
	   (y (##core#inline "C_copy_block" old (make-vector words))) )
      (##sys#become! (list (cons old (proc y))))
      y) )