;; trace
;; package to trace functions individually in klone

(setq *package* 'trace)
;;
;; Tracing of functions.
;;
;;AUTOLOAD: trace
;;AUTODOC: trace "trace individual functions"
;; (trace <function> [:entry <expression>] [:exit <expression>])
;;
;; Records a function to trace
;; Where the keywords :entry and :exit define expressions evaluated
;; when entering or exiting the function. The value `#trace:value' or 
;; trace::res is the value returned by the function.
;;
;; (trace ()) returns the list of traced functions
;; Output is limited to trace:maxprint charcters per trace (defaults to 240)
;;
;;SEE_ALSO: untrace

;; trace relace function 
;; (lambda foo (args...) x y z) by:
;; (lambda foo (&rest args)
;;    (PF *standard-error* "***foo[level] : arg1=%0 ...\n" args...)
;;    (with (trace::res (progn x y z))
;;       (PF *standard-error* "***foo[level] -> %r0\n" trace::res)
;;    ))

(defunq trace (trace:funcname &key ((:entry trace:entry) ()) ((:exit trace:exit) ())
    &aux
    trace:function
    trace:type
  )
  (if (not (typep trace:funcname Atom))
    (error "trace argument %r0 is not a function name!" trace:funcname)
  )
  (setq trace:function (eval trace:funcname))
  (if (not (typep trace:function Function)) 
    (error "trace argument %r0 is not a function!" trace:function)
  )
  (unless (seek trace:list-of-functions trace:funcname)
    (setq trace:type				;evaluate arguments?
      (if (seek (vector Expr Subr) (type-of trace:function)) lambda lambdaq)
    )
    (lappend trace:list-of-functions trace:funcname)
    (set trace:funcname
      (eval `(,trace:type (&rest trace::args &aux (trace:level (,+ trace:level 1)))
	  (trace:print-args t ',trace:funcname trace::args trace:level)
	  ,(if trace:entry trace:entry)
	  (,with (trace::res (,apply ,trace:function trace::args))
	    (trace:print-args () ',trace:funcname trace::res trace:level)
	    ,(if trace:exit (list with '(#trace:value trace::res) trace:exit))
	    trace::res
  )))))
  trace:funcname
)

(defvar trace:level -1)
(defvar trace:maxprint 240)
(defvar trace:list-of-functions (vector))

(defun trace:print-args (enter? funcname args level &aux
    (s (print-format String 
	(if enter? 
	  "##>%0[%1]->%r2"
	  "##<%0[%1]<- %r2"
	)
	funcname level args
  )))
  (if (> (length s) trace:maxprint) (setq s (subseq s 0 trace:maxprint)))
  (print-format *standard-error* "%n0\n" s)
)

;;
;;	Untracing of functions
;;
;;AUTOLOAD: untrace
;;AUTODOC: untrace "removes trace on an individual function"
;;  (untrace <function> *)
;;
;; Untrace a function.
;; The function `untrace' makes <function> to be traced no more and returnes
;; the list of the traced functions. If <function> is not specified then
;; all functions are untraced.
;;SEE_ALSO: trace

(defunq untrace (&optional trace:funcname)
  (if trace:funcname
    (if (seek trace:list-of-functions trace:funcname) (progn
	(set trace:funcname
	  (with (funcdef (List (eval trace:funcname)))
	    (1 (1 (1 (3 funcdef))))
	))
	(delete-nth trace:list-of-functions
	  (seek trace:list-of-functions trace:funcname))
    ))
    trace:list-of-functions
))
