static-analysis.lisp

;=bobak@balisp.org fix for: https://github.com/AccelerationNet/static-analysis .lisp file =
 
(cl:defpackage :static-analysis
  (:use :cl :cl-user :iterate)
  (:export #:function-call-graph
           #:->dot
           #:call-graph->dot))

(in-package :static-analysis)
;having problems loading: https://github.com/AccelerationNet/static-analysis.git
;so loading these 3fncs first
 
;λ▶<14 j29local: /src/software> vi slime-20131211-cvs/contrib/swank-asdf.lisp
; defslimefun asdf-system-files (name)
(defun asdf-system-files (name)
  (let* ((system (asdf:find-system name))
         (files (mapcar #'namestring
                        (cons
                         (asdf:system-definition-pathname system)
                         (asdf-component-source-files system))))
         (main-file (find name files
                          :test #'equalp :key #'pathname-name :start 1)))
    (if main-file
        (cons main-file (remove main-file files
                                :test #'equal :count 1))
        files))) 


;/usr/share/common-lisp/source/cl-asdf/asdf.lisp
(defun coerce-name (name)
;defun* coerce-name (name)
  (typecase name
    (component (component-name name))
    (symbol (string-downcase (symbol-name name)))
    (string name)
    (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name)))) 

;"util_mb.lisp" 2811L, 103204C                                            1225,15       43%
(defun simple-replace-string (old new string) ;some replacements could be get it stuck/?
  "Replace OLD with NEW into STRING."
  (loop
     with changed = t
     while changed
     do (setf string
              (let ((match (search old string :test #'string-equal ;equal
                   )))
                (if match
                    (prog1
                        (concatenate 'string (subseq string 0 match) new (subseq string (+ match (length old))))
                      (setf changed t))
                    (prog1
                        string
                      (setf changed nil)))))
       finally (return string))) 

;=use: http://ryepup.unwashedmeme.com/blog/2012/01/03/visualizing-call-graphs-in-lisp-using-swank-and-graphviz/
;USER (2):  (in-package :static-analysis)
;
;#<PACKAGE "STATIC-ANALYSIS">
;STATIC-ANALYSIS (3):  (call-graph->dot :alexandria )
;
;digraph g{
;subgraph clusterG917{
;...

;= end - fix rest is as from https://github.com/AccelerationNet/static-analysis lisp file

(defun asdf-files (system)
  "generates a list of files in the ASDF system, in load order"
 ;(rest (swank:asdf-system-files system))
  (rest (asdf-system-files system)) ;lt first
  )

(defun read-file (path)
  (check-type path pathname)
  (with-open-file (s path)
    (iter
      (for form = (read s nil 'done))
      (until (eq form 'done))
      (collect form))))

(defun callers (symbol)
  (check-type symbol symbol)
  (mapcar #'first
          (or (ignore-errors
               (and (fdefinition symbol)
                    (swank-backend:who-calls symbol)))
              (swank-backend:who-macroexpands symbol))))

(defun ensure-package-list (packages)
  (when packages
    (let ((packages (alexandria:ensure-list packages)))
      (if (every #'packagep packages) packages
          (mapcar #'find-package (alexandria:flatten packages))))))

(defun map-symbols (fn packages &aux (packages (ensure-package-list packages)))
  (check-type fn function)
  (check-type packages list)
  (with-package-iterator (gen packages :internal :external :inherited)
    (with-simple-restart (abort "stop iterating")
      (iter (multiple-value-bind (more? symbol accessibility pkg) (gen)
              (with-simple-restart (continue "skip to the next symbol")
                (funcall fn symbol accessibility pkg))
              (while more?))))))


;; ;; throws compiler error
;; (defun package-iterator (x)
;;   (when (every #'packagep x)
;;       (with-package-iterator (gen x :internal :external :inherited)
;;         (gen))))

(defun orphan-p (symbol)
  (break "~A, callers: ~a, refs: ~a, binds: ~a, sets: ~a, specs: ~a" symbol
         (callers symbol)
         (swank-backend:who-references symbol)
         (swank-backend:who-binds symbol)
         (swank-backend:who-sets symbol)
         (swank-backend:who-specializes symbol)))

(defun check-for-orphans (package)
  (check-type package package)
  (map-symbols #'(lambda (symbol accessibility pkg)
                   (when (orphan-p symbol)
                     (format T "~&~A ~A ~A~%" symbol pkg accessibility))
                   )
               package))

(defstruct (cluster (:print-object cluster-printer))
  label
  (nodes (list))
  (graphviz-name (gensym)))

(defun cluster-printer (cluster stream)
  (print-unreadable-object (cluster stream :type T :identity T)
    (format stream "label: ~a, nodes: ~a" (cluster-label cluster)
            (length (cluster-nodes cluster)))))

(defstruct (node (:print-object node-printer))
  label
  (graphviz-name (gensym))
  (cluster nil)
  (called-from (list))
  (calls (list)))

(defun node-printer (node stream)
  (print-unreadable-object (node stream :type T :identity T)
    (format stream "label: ~a, calls: ~a, called ~a" (node-label node)
            (length (node-calls node))
            (length (node-called-from node)))))

(defvar *call-graph-cache* (make-hash-table))
(defun call-graph (packages &aux
                            (packages (ensure-package-list packages))
                            pkgs)
  (labels ((ensure-pkg (sym &aux (pkg (package-name (symbol-package sym))))
             (or
              (find pkg pkgs :test #'string= :key #'cluster-label)
              (first (push (make-cluster :label pkg) pkgs))))
           (ensure-sym (sym &aux (cluster (ensure-pkg sym))
                            (label (symbol-name sym)))
             (or (find label (cluster-nodes cluster)
                       :test #'string= :key #'node-label)
                 (first (push
                         (make-node :label label :cluster cluster)
                         (cluster-nodes cluster)))))
           (edge (sym caller &aux
                             (sym (ensure-sym sym))
                             (caller (ensure-sym caller)))
             (pushnew sym (node-calls caller))
             (pushnew caller (node-called-from sym)))
           (process-sym (symbol accessibility pkg)             
             (declare (ignore accessibility pkg))
             (let ((callers (remove-duplicates
                             (mapcar #'(lambda (caller)
                                         ;; something like
                                         ;; (DEFMETHOD fn (args))
                                         (if (listp caller)
                                             (let ((fn (second caller)))
                                               ;; something like (setf foo)
                                               (if (listp fn) (second fn)
                                                   fn))
                                             caller))
                                     (callers symbol)))))
               (dolist (c callers)
                 (edge symbol c)))))
    
    (map-symbols #'process-sym packages))
  
  pkgs)

(defun graphviz-escape (string)
 ;(adwutils:replace-all string ">" "&gt;")
 ;simple-replace-string (old new string)
  (simple-replace-string ">" "&gt;" string)
  )

(defun ->dot (clusters &optional (stream T)
              &aux (*print-pretty* nil))
  (format stream "~&digraph g{~%")
  (with-open-stream (edges (make-string-output-stream))
    (dolist (cluster clusters)
      (format stream
              "~&subgraph cluster~a{~%label=\"~a (~a nodes)\"~%"
              (cluster-graphviz-name cluster)
              (cluster-label cluster)
              (length (cluster-nodes cluster)))
      (dolist (node (cluster-nodes cluster))
        (format stream "~a [shape=\"record\",label=\"" (node-graphviz-name node))
        (let ((in-count (length (node-called-from node)))
              (out-count (length (node-calls node)))
              (label (graphviz-escape (node-label node))))
          
          (cond
            ((or
              (and (zerop in-count) (zerop out-count))
              (and (= 1 in-count) (= 1 out-count)))
             (format stream "<in>~a" label))
            ((and (zerop in-count) (= 1 out-count)) (format stream "<out>~a" label))
            ((zerop in-count) (format stream "{~a|<out>~a out}" label out-count))
            
            ((and (= 1 in-count) (zerop out-count)) (format stream "<in>~a" label))
            ((= 1 in-count) (format stream "{<in>~a|<out>~a out}" label out-count))

            ((and (plusp in-count) (zerop out-count))
             (format stream "{<in>~a in|~a}" in-count label))
            ((and (plusp in-count) (= 1 out-count))
             (format stream "{<in>~a in|<out>~a}" in-count label))
            
            (T (format stream "{<in>~a in|~a|<out>~a out}" in-count label out-count))
            )

          (format stream "\"]~%")
          (dolist (n (node-calls node))
            (format edges 
                    (if (and (= 1 in-count) (= 1 out-count))
                        "~a -> ~a:in~%"
                        "~A:out -> ~A:in~%"
                        )
                        (node-graphviz-name node)
                        (node-graphviz-name n))
            )

          ))
      (format stream "}~%"))
    (format stream (get-output-stream-string edges)))
  (format stream "~&}~%"))

(defun save-as-svg (path graph &aux (path (merge-pathnames path)))
  (with-open-file (stream path :direction :output :if-exists :supersede)
    (->dot graph stream))
  (sb-ext:run-program "/usr/bin/dot" (list "-Tsvg" "-O" (princ-to-string path)))
  (truename path))

(defun call-graph->dot (packages &optional (stream T))
  (->dot (call-graph packages) stream))


(defun function-call-graph (packages symbols
                            &optional (max-depth 1024) call-graph
                            &aux nodes-to-keep
                            seen)
  "spiders down from symbols"
  (labels ((add-nodes (node &optional (depth 0))
             (when (and node (< depth max-depth))
               (pushnew node nodes-to-keep)
               (unless (member node seen)
                 (push node seen)
                 (dolist (n (node-calls node))
                   (add-nodes n (1+ depth)))))))
    (iter
      (with call-graph = (or call-graph (call-graph packages)))
      (for sym in symbols)
      (for cluster = (find (package-name (symbol-package sym))
                           call-graph
                           :test #'string= :key #'cluster-label))
      (for node = (find (symbol-name sym)
                        (cluster-nodes cluster)
                        :test #'string= :key #'node-label))
      (add-nodes node)))
  (iter (for n in nodes-to-keep)
    (setf (node-calls n)
          (intersection (node-calls n)
                        nodes-to-keep)))
  (iter
    (for cluster in (remove-duplicates (mapcar #'node-cluster nodes-to-keep)))
    (collect
        (make-cluster :label (cluster-label cluster)
                      :nodes (remove-if-not #'(lambda (node)
                                                (eq cluster (node-cluster node)))
                                            nodes-to-keep)))))

(defun function-caller-graph (packages symbols
                            &optional (max-depth 1024) call-graph
                            &aux nodes-to-keep
                            seen)
  "spiders down from symbols"
  (labels ((add-nodes (node &optional (depth 0))
             (when (and node (< depth max-depth))
               (pushnew node nodes-to-keep)
               (unless (member node seen)
                 (push node seen)
                 (dolist (n (node-called-from node))
                   (add-nodes n (1+ depth)))))))
    (iter
      (with call-graph = (or call-graph (call-graph packages)))
      (for sym in symbols)
      (for cluster = (find (package-name (symbol-package sym))
                           call-graph
                           :test #'string= :key #'cluster-label))
      (for node = (find (symbol-name sym)
                        (cluster-nodes cluster)
                        :test #'string= :key #'node-label))
      (add-nodes node)))
  (iter
    (for cluster in (remove-duplicates (mapcar #'node-cluster nodes-to-keep)))
    (collect
        (make-cluster :label (cluster-label cluster)
                      :nodes (iter (for node in nodes-to-keep)
                               (when (eq cluster (node-cluster node))
                                 ;; make a copy
                                 (let ((copy-node (copy-node node )))
                                   ;; modify it's call lists to stay within this graph
                                   (setf (node-calls copy-node)
                                         (intersection (node-calls node)
                                                       nodes-to-keep)

                                         (node-called-from copy-node)
                                         (intersection (node-called-from node)
                                                       nodes-to-keep)
                                         )
                                   (collect copy-node))))))))


(defun asdf-systems (&aux (sys (list)))
  (asdf:map-systems #'(lambda (sy) (push sy sys)))
  sys)


(defvar *syscache* (make-hash-table))
(defgeneric asdf-dependencies (thing)
  (:method ((a asdf:system)) (slot-value a 'asdf::load-dependencies))
  (:method ((a T)) (asdf-dependencies (alexandria:ensure-gethash
                                       a *syscache*
                                       (asdf:find-system a)))))

(defmethod asdf-depends-on-p ((a asdf:system) b)
  (member b (asdf-dependencies a)))

(defun asdf-who-depends (system-keyword)
  "finds out who depends on the given system"
  (remove-if-not #'(lambda (system)
                     (asdf-depends-on-p system system-keyword))
                 (asdf-systems)))

(defmethod keyword-name ((a asdf:system))
  (alexandria:make-keyword (string-upcase 
 ;(asdf:coerce-name a)
  (coerce-name a)
  )))

(defun %asdf-graph (root cluster systems)
  (let ((root-node (or (find root (cluster-nodes cluster) :key #'node-label
                             :test #'string-equal)
                       (first (push (make-node :label (princ-to-string root) :cluster cluster)
                                    (cluster-nodes cluster))))))
    (dolist (parent (asdf-dependencies root))
      (let ((parent-node (%asdf-graph parent cluster systems)))
        (pushnew parent-node (node-calls root-node))
        (pushnew root-node (node-called-from parent-node))))
    root-node))

(defun asdf-graph (roots
                   &aux (cluster (make-cluster :label "ASDF load graph"))
                   (systems (asdf-systems))
                   (roots (alexandria:ensure-list roots)))
  (dolist (root roots)
    (%asdf-graph root cluster systems))
  cluster)