;;;;;;; --- Profile Your Functions --- ;;;;;;;;;
;;   by (C.) Vladimir Nesterovsky, December 1998.
;; vnestr@netvision.net.il,  http://vnestr.tripod.com
;;   Free for *non-commercial* personal use only
;;         with this notice unchanged.
;;
;; Here's an AutoLISP profiler for measuring the execution
;; speed of your functions. Good for r12-r14; to use it under
;; r2000, change all your DEFUN's to DEFUN-Q's.
;; Unfortunately, we don't have access to a function's
;; lambda-list anymore in r2000's VisualLISP. :-(
;;
;; Happy profiling!
;;
;;
;; usage: (profile-func 'your-function), then
;;        call it or a program that's calling it,
;;        then use (show-timers).
;;        When finished, call (profile-stop).
;;
;; potential problems:
;;  slows down the execution while profiling many functions;
;;  time is measured by (getvar "date") that might not have
;;  fine enough resolution, depending on platform,
;;  so timings for fast routines might be not so reliable.
;;  but you can measure the execution of many repetitions of the
;;  same code with (defun test()(repeat 10000 (yourfunction)))
;;  and profiling it instead, with (profile-func 'test).
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; global variables
;;  vpn__profiled_funcs *symbol-names*
;;  various "vpn__*" vars during the execution
(DEFUN PROFILE-FUNC( FSYM / f fname arg-list formals )
 (if (not (atom fsym))
  (mapcar 'profile-func fsym)
  (cond
    ((or (/= 'SYM (type FSYM))
          (not (ufuncp (SETQ F (EVAL FSYM))))
     )
     (mapcar 'princ '(
       " must be quoted symbol of"
       " user-defined function to be profiled. "))
     (princ)
     )
    ((member fsym vpn__profiled_funcs)
      (princ " ")
      (princ (sym2str fsym))
      (princ " is being profiled already. ")
      (princ)
     )
    (T
      ;; profile this function
      (setq fname (sym2str fsym))

      (IF (= 'PAGETB (TYPE(CAR F))) ;; r12 stuff :-)))
        (SETQ F (CDR F))
      )
      (SET (READ (STRCAT "vpn__orig_func_" FNAME)) F)

      (SETQ ARG-LIST (CAR F)
            FORMALS (if (MEMBER '/ ARG-LIST)
                      (REVERSE (CDR (MEMBER '/
                         (REVERSE ARG-LIST))))
                      arg-list
                    )
      )
      (princ
      (EVAL (LIST 'DEFUN Fsym
                    (append formals
                      (list '/ 'result 'strtm 'endtm ))
        '(setq strtm (getvar "date"))
        (LIST 'SETQ 'RESULT
              (CONS (READ (STRCAT "vpn__orig_func_" FNAME))
                            FORMALS))
        '(setq endtm (getvar "date"))
        (list '+= (list 'quote
               (READ (STRCAT "VPN__TIMER_FOR_" FNAME)))
            '(* 86400 (- endtm strtm))
        )
        (list '+= (list 'quote
          (read (strcat "vpn__calls_for_" FNAME))) 1)
        'RESULT
      )))
      (setq vpn__profiled_funcs
        (cons fsym vpn__profiled_funcs))
      (princ " ")
      (princ)
    )
  )
))

(defun profile-stop()
  (restore-funcs)
  (foreach x
    (atoms "vpn__timer_for_*,vpn__calls_for_*")
    (set (read x) nil)
  )
  (setq vpn__profiled_funcs nil)
)

(DEFUN RESTART-TIMERS()
  (foreach x (atoms "vpn__timer_for_*,vpn__calls_for_*")
    (set (read x) 0)
  )
)

(defun show-timers( / as nn tm )
 (cond
  ((setq as (atoms "vpn__timer_for_*"))
   (foreach x (acad_strlsort as)
    (princ "\n")
    (princ (substr x 6))(princ ": n=")
    (princ (setq nn (eval (read
       (strcat "vpn__calls_for_" (substr x 16))))))
    (princ ", t=")
    (princ (setq tm (eval (read x))))
    (princ ", t/call=")(princ
       (if (zerop nn) "N/A" (/ (float tm) nn)))
    (princ ".")
   ))
  ((princ "\n No timers are being maintained."))
  )
 (princ "\n")
 (princ)
)

(defun restore-funcs()
  (foreach x (atoms "vpn__orig_func_*")
    (set (read (substr x 16)) (eval (read x)))
    (set (read x) nil)
  )
)

(defun restore-func(s / q2)
  (if (strp s)
    (if (eval (setq q2 (read
                (strcat "vpn__orig_func_" s))))
    (progn
      (set (read s) (eval q2))
      (set q2 nil)
      (setq vpn__profiled_funcs
        (minuslist vpn__profiled_funcs (list (read s))))
      (foreach x
        (atoms (strcat "vpn__timer_for_" s
                       ",vpn__calls_for_" s))
        (set (read x) nil)
      )
    ))
    (if s (restore-func (sym2str s)))
))

(defun show-funcs()
  (foreach x (atoms "vpn__orig_func_*")
   (print (list (setq x (substr x 16)) (eval(read x)))))
  (princ)
)

(defun sym2str (sym )
 (if (null *symbol-names*) ;; cache list empty
     (setq *symbol-names*  ;; build it
       (mapcar 'cons
         (atoms-family 0)
         (atoms-family 1))))
 (cond
   ((cdr(assoc sym *symbol-names*)))
   ((cdar    ;; update cache list using SYMSTR
    (setq *symbol-names*
      (cons (cons sym (symstr sym))
            *symbol-names*)))) ))

;;convert symbol to string; found on Internet.
(defun symstr (sym)
    (if (= (type sym) 'SYM)
      ( (list
          (if (boundp sym)
            (cons '/ (atoms-family 0))
            (cons '/ (cons sym (atoms-family 0)))
          )
          (list setq sym 1)
          (list car (list atoms-family 1))
        ) ) ) )

(defun ufuncp(f)   ;; User FUNCtion Predicate
  (and
    f
    (listp f)
    (or
      (null (car f))              ;; no args
      (= (type (car f)) 'PAGETB)  ;; VMON
      (and                        ;; args list
        (listp (car f))
        (null (cdr (last* (car f))))   ;; not dotted list
        (apply '= (cons 'SYM
          (mapcar 'type (car f)))) ) ) ) )

;; last cons cell of a list
(defun last* (lst)
  (while (not (atom (cdr lst)))
    (setq lst (cdr lst)))
  lst)

(defun += (symbolvariable incrementvalue)
 (if (numberp (eval symbolvariable))
   (set symbolvariable (+ incrementvalue
     (eval symbolvariable)))
   (set symbolvariable incrementvalue)
 ))

(defun atoms (pattern / lst)
 (setq pattern (strcase pattern))
 (foreach atomstring (atoms-family 1)
  (if (wcmatch atomstring pattern)
    (setq lst (cons atomstring lst))))
 (reverse lst))

(defun minuslist ( fromlist elementslist / tmplst )
 (foreach element fromlist
   (if (not (member element elementslist))
     (setq tmplst (cons element tmplst))))
 (reverse tmplst)
)

(defun profile-usage()
  (mapcar 'princ '(
    "\n       ---= Profile AutoLISP functions =---  "
    "\n by Vladimir Nesterovsky, vnestr@netvision.net.il"
    " 1998.\n\nUse (PROFILE-FUNC 'fsym), (RESTORE-FUNCS),"
    " (SHOW-FUNCS), (SHOW-TIMERS), "
    "\n (RESTART-TIMERS), (PROFILE-USAGE) "
    "and (PROFILE-STOP) to stop profiling."
    ))
  (princ)
)
(profile-usage)
;;;;;;;;;; PROFILE ends ;;;;;;;;;;;