picolisp

Unnamed repository; edit this file to name it for gitweb.
git clone https://logand.com/git/picolisp.git/
Log | Files | Refs | README | LICENSE

prof.l (1284B)

      1 # 15may07abu
      2 # (c) Software Lab. Alexander Burger
      3 
      4 # *Profile
      5 
      6 (de _prf? (Lst)
      7    (and (pair Lst) (== 'tick (caadr Lst))) )
      8 
      9 (de _prf (Lst)
     10    (when (pair Lst)
     11       (if (_prf? Lst)
     12          (prog1
     13             (cadr (cadr Lst))
     14             (set (cdadr Lst) (cons (+ 0) (+ 0))) )
     15          (con
     16             Lst
     17             (list (cons 'tick (cons (+ 0) (+ 0)) (cdr Lst))) )
     18          T ) ) )
     19 
     20 (de "uprf" (Lst)
     21    (when (_prf? Lst)
     22       (con Lst (cddr (cadr Lst)))
     23       T ) )
     24 
     25 (de prof ("X" "C")
     26    (when (pair "X")
     27       (setq  "C" (cdr "X")  "X" (car "X")) )
     28    (and (not "C") (num? (getd "X")) (expr "X"))
     29    (unless
     30       (and
     31          (_prf (if "C" (method "X" "C") (getd "X")))
     32          (push1 '*Profile (cons "X" "C")) )
     33       (quit "Can't profile" "X") ) )
     34 
     35 (de unprof ("X" "C")
     36    (del (cons "X" "C") '*Profile)
     37    ("uprf" (if "C" (method "X" "C") (getd "X"))) )
     38 
     39 (de profile ()
     40    (mapc println
     41       (flip
     42          (by '((X) (+ (car X) (cadr X))) sort
     43             (mapcar
     44                '(("X")
     45                   (let P
     46                      (_prf
     47                         (if (cdr "X")
     48                            (method (car "X") (cdr "X"))
     49                            (getd (car "X")) ) )
     50                      (cons (car P) (cdr P) "X") ) )
     51                *Profile ) ) ) ) )