#!/bin/sh
: ; exec klone $0 "$@"
; The above line finds the klone executable in the $PATH
;; script to print a profiling dump, just like "gprof"
;; use with the same arguments, i.e. gmon-dump klone
;; prints (ascii) to output, and adds a table of declared lambdas at the end
;; no arguments = filter

;(setq *error-handlers* (lambda (errorcode &rest args)
;    (PF *standard-error* "errocde: %0, values: %r1\n" errorcode args)
;    (PF *standard-error* "func-values = %0\n" (List func-values))
;    :true
);)
(stack-dump-on-error t)

(defun function-name-format (x) (+ "'" x)) ; how to print lambdas

;; first gets the standard output of gprof

(setq command "gmon")
(dolist (arg (subseq *arguments* 1)) (nconc command " " arg))
(nconc command " > gmon.rtxt")
(if (> (length *arguments*) 1) 
    (wait (system command)) ; generates gmon.rtxt
)

;; sets up tables
(setq func-names (Hashtable ()))
(with (fd (open "gmon.names")
    re (regcomp "^([^ ]*)[ ](.*)$")
  )
  (while (setq line (read-line fd ()))
    (if (regexec re line)
      (put func-names (regsub re "\\1") (regsub re "\\2"))
)))
(setq func-values (Hashtable ()))
(with (fd (open "gmon.values")
    re (regcomp "^([^ ]*)[ ][^ ]*[ ](.*)$")
  )
  (while (setq line (read-line fd ()))
    (if (regexec re line)
	(put func-values (regsub re "\\1") (regsub re "\\2"))
)))

;; replaces all strings of dummy C functions by the proper ones

(if (> (length *arguments*) 1) 
  (setq fd (open "gmon.rtxt"))
  (setq fd *standard-input*)
)

(setq re (regcomp "([_.]?(Kl__Func_[0-9]*))"))
(while (setq line (read-line fd ()))
  (while (regexec re line)
    (setq line (+ (subseq line 0 (get (get re 1) 0))
	(apply function-name-format (list (get func-names (regsub re "\\2"))))
	(subseq line (get (get re 1) 1))
    ))
  )
  (write-line line)
)
      
;; add a table of lambdas at the end
(write-line
  "\n\n======================================================================")
(write-line "Anonymous Lambdas")
(write-line
  "======================================================================")

;; sort lambdas
(setq ordered-lambdas (list))
(setq ordered-funcs (list))

(dohash (cfunc wfunc func-names)
  (if (match "^Lambda#[0-9]+$" wfunc) (progn
      (setq n (- (Int (match "^Lambda#([0-9]+)$" wfunc 1)) 1))
      (put ordered-lambdas (* 2 n) wfunc)
      (put ordered-lambdas
	(+ 1 (* 2 n)) (read (Stream (get func-values cfunc))))
    )
    ;; else
    (put ordered-funcs -1
      (list wfunc (read (Stream (get func-values cfunc)))))
))

;; then print them
(setq one-done ())
(dohash (wfunc func ordered-lambdas)
  (if one-done (write-line
      "------------------------------------------------------------------------------"
  ))
  (setq one-done t)
  (write-line wfunc)
  (if (progn (trap-error 'ALL (pp func)) trap-error:caught)
    (print-format "***PP ERROR, raw listing***\n%r0" (List func))
  )
  (write-line "")
)

;; add a table of functions at the end
(write-line
  "\n\n==============================================================================")
(write-line "Definition of Named Functions, alphabetically sorted")
(write-line
  "==============================================================================")
(sort ordered-funcs (lambda (x y) (compare (get x 0) (get y 0))))
(setq one-done ())
(dolist (funcs ordered-funcs)
  (if one-done (write-line
      "------------------------------------------------------------------------------"
  ))
  (setq one-done t)
  (write-line (get funcs 0))
  (if (progn (trap-error 'ALL (pp (get funcs 1))) trap-error:caught)
    (print-format "***PP ERROR, raw listing***\n%r0" (List (get funcs 1)))
  )
  (write-line "")
)