; implements various analyses on the IR

(in-package "VERRAZANO-COMMON")

; can an element be named?
(defun named? (el)
  (subtypep (type-of el) 'named))

; is an element anonymous?
(defun anonymous? (el)
  (and (named? el)
       (or
	 (equal (named-name el) "")
	 (starts-with "._" (named-name el))
	 (not (named-name el)))))

; is an edge a defines edge?
(defun defines-edge? (e)
  (subtypep (type-of e) 'defines))

; is an edge a returns edge?
(defun returns-edge? (e)
  (subtypep (type-of e) 'returns))

; is an edge an extends edge?
(defun extends-edge? (e)
  (subtypep (type-of e) 'extends))

; is an edge a receives edge?
(defun receives-edge? (e)
  (subtypep (type-of e) 'receives))

; is an edge an allocates edge?
(defun allocates-edge? (e)
  (subtypep (type-of e) 'allocates))

; is the given edge a function?
(defun function? (e)
  (and (eq (type-of e) 'allocates)
       (eq (type-of (edge-target e)) 'function-type)))

; is the given edge a method?
(defun method? (e) (function? e))

; is the given function a static method?
(defun static-method? (e)
  (and (method? e)
       (get-note (edge-target e) 'static)))

; is the given function a non-virtual method?
(defun ordinary-method? (e)
  (and (method? e)
       (not (static-method? e))
       (not (virtual-method? e))))

; is the given function a virtual method?
(defun virtual-method? (e)
  (and (method? e)
	   (subtypep (type-of e) 'allocates-virtual)))

; is the given function a virtual destructor?
(defun virtual-destructor? (e)
  (and (virtual-method? e)
	   (destructor-function? e)))

; is the given function a morally virtual method?
(defun morally-virtual-method? (e node)
  (and (method? e)
       (or
	 (virtual-method? e)
	 (some #'virtual-method? 
	       (equivalent-base-methods e node)))))

; is the given function a special function?
(defun special-function? (e)
  (and (function? e)
	   (not (eq (type-of (edge-target e)) 'function-type))))

; is the given function a converter?
(defun converter-function? (e)
  (and (special-function? e)
	   (subtypep (type-of (edge-target e)) 'converter-type)))

; is a given function an operator?
(defun operator-function? (e)
  (and (special-function? e)
	   (subtypep (type-of (edge-target e)) 'operator-type)))

; is a given function a constructor?
(defun constructor-function? (e)
  (and (special-function? e)
	   (subtypep (type-of (edge-target e)) 'constructor-type)))

; is a given function a destructor?
(defun destructor-function? (e)
  (and (special-function? e)
	   (subtypep (type-of (edge-target e)) 'destructor-type)))

; is a method a trivial constructor?
(defun trivial-constructor? (e)
  (and (eq (type-of e) 'allocates)
	   (constructor-function? e)
       (search "*INTERNAL*" (named-c-name e))))

; is a given type an array?
(defun array-type? (n)
  (subtypep (type-of n) 'array-type))

; is the given type a class?
(defun class-type? (n)
  (subtypep (type-of n) 'class-type))

; is the given type a struct?
(defun struct-type? (n)
  (subtypep (type-of n) 'struct-type))

; is the given type composite?
(defun composite-type? (n)
  (member (type-of n) '(class-type struct-type)))

; is the given type a namespace?
(defun namespace? (n)
  (subtypep (type-of n) 'namespace-type))

; is a given type a fundamental type?
(defun fundamental-type? (n)
  (subtypep (type-of n) 'fundamental-type))

; is a given type a constant?
(defun constant-type? (n)
  (and (subtypep (type-of n) 'constant-type)))

; is a given type an alias type?
(defun alias-type? (n)
  (subtypep (type-of n) 'alias-type))

; get the resolved node (following typedef chains)
(defgeneric resolved-node (n))

(defmethod resolved-node ((n cpp-type)) n)

(defmethod resolved-node ((n alias-type))
  (resolved-node (first-adjacent-node n)))
       
; is a given type a constant fundamental type?
(defun constant-fundamental? (n)
  (and (constant-type? n)
       (fundamental-type? (first-adjacent-node n))))

; is a given type a constant integer type?
(defun constant-integer? (n)
  (and (constant-fundamental? n)
       (equal (named-name (first-adjacent-node n)) "int")))

; what is the real type of node?
(defun real-type (n)
  (if (composite-type? n)
    (if (some #'(lambda (e)
		  (or (eq (type-of e) 'extends)
		      (and (method? e)
			   (not (trivial-constructor? e)))))
	      (node-edges n))
      'class-type
      'struct-type)
    (type-of n)))

; what is the size of a node
(defgeneric type-size (n))

(defmethod type-size ((n concrete-type))
  (concrete-type-size n))

(defmethod type-size ((n alias-type))
  (type-size (first-adjacent-node n)))

; what is the alignment of a type?
(defgeneric type-align (n))

(defmethod type-align ((n concrete-type))
  (concrete-type-align n))

(defmethod type-align ((n alias-type))
  (type-align (first-adjacent-node n)))

; what is the return type of a function?
(defun function-return-type (fun)
  (edge-target (find-if #'returns-edge? 
			(node-edges (edge-target fun)))))

; if a function is a method, get its this argument
(defun function-this-argument (fun)
  (when (method? fun)
    (find-if #'receives-edge? (node-edges (edge-target fun)))))

; if a function is a method, get all its non-this arguments
(defun function-non-this-arguments (fun)
  (when (method? fun)
    (remove (function-this-argument fun)
	    (find-all #'receives-edge? (node-edges (edge-target fun))))))

; get the arguments of a function
(defun  function-arguments (fun)
  (find-all #'receives-edge? (node-edges (edge-target fun))))

; what are the argument types of a function?
(defun function-argument-types (fun)
  (mapcar #'edge-target (find-all #'receives-edge? 
				  (node-edges (edge-target fun)))))

; return all of the bases of a composite type
(defun edges-to-bases (node)
  (find-all #'extends-edge? (node-edges node)))

; determine if a base class is virtual
(defun virtual-base? (edge)
  (extends-edge-virtual edge))

; given a class, determine whether it is a dynamic class
(defun dynamic-class? (node)
  (or (some #'virtual-method? (node-edges node))
      (some #'dynamic-class? (all-adjacent-nodes node '(extends)))))

; given a class, determine whether it is a category 0 class
(defun category0-class? (node)
  (and (not (dynamic-class? node))
       (notany #'dynamic-class? (all-adjacent-nodes node '(extends)))))

; given a class, determine whether it is a leaf class in the hierarchy
(defun category1-class? (node)
  (and (dynamic-class? node)
       (notany #'dynamic-class? (all-adjacent-nodes node '(extends)))))

; given a class, determine whether it is a category 2 class
(defun category2-class? (node)
  (and (dynamic-class? node)
       (some #'dynamic-class? (all-adjacent-nodes node '(extends)))))

; given a class, return the edge to its primary base, if it has one
(defun edge-to-primary-base (node)
  (find-if #'(lambda (e)
	       (dynamic-class? (edge-target e))) (node-edges node)))

; compute offset required to convert derived* to base*
(defun compute-conversion-offset (derived base)
    (compute-offset-helper derived base 0))

; helper function for computing converesion offset
(defun compute-offset-helper (curr base offset)
  (when (eq curr base) offset)
  (some #'non-nil? 
	(mapcar #'(lambda (e)
		    (compute-offset-helper 
		      (edge-target e) base 
		      (+ offset (extends-edge-offset e))))
		(edges-to-bases curr))))

; return all the methods of a class
(defun class-methods (node)
  (find-all #'method? (node-edges node)))

; return all of the virtual functions of a class
(defun class-virtual-methods (node)
  (find-all #'virtual-method? (node-edges node)))

; return a list of all methods in bases equivalent to fun
(defun equivalent-base-methods (tofun node)
  (let ((eqlist nil))
    (dolist (base (edges-to-bases node) eqlist)
      (dolist (fun (class-methods (edge-target base)))
	(when (functions-equivalent? fun tofun)
	  (push fun eqlist))))))

; return the vtable of the primary base class
(defun primary-base-vtable (node)
  (when (composite-type? node)
    (let ((pbe (edge-to-primary-base node)))
      (when pbe
	(get-note (edge-target pbe) 'virtual-table)))))

; return the vtables of every non-primary base class
(defun non-primary-base-vtables (node)
  (when (composite-type? node)
    (let ((pbvt (primary-base-vtable node)))
      (remove pbvt (mapcar #'(lambda (b)
			      (get-note b 'virtual-table))
			  (all-adjacent-nodes node '(extends)))))))

; is the method declared below an override of a primary base method?
(defun overrides-primary-method? (fun pvt)
  (some #'(lambda (pvtent)
	    (when pvtent
	      (functions-equivalent? fun pvtent))) pvt))

; determine whether two functions have identical signatures
(defun signatures-equivalent? (fun1 fun2)
  (and (eq (function-return-type fun1) (function-return-type fun2))
       (every #'eq 
	      (function-argument-types fun1)
	      (function-argument-types fun2))))

; determine whether two functions are the same
(defun functions-equivalent? (fun1 fun2)
  (and (equal (named-name fun1) (named-name fun2))
       (signatures-equivalent? fun1 fun2)))

; compute the vtable index of a given function in class's vtable
(defun lookup-vtable-index (fun cls)
  (when (virtual-method? fun)
    (let ((vtbl (get-note cls 'virtual-table)))
      (multiple-value-bind (expos eqpos) (lookup-method-in-vtable fun vtbl)
	(if expos expos eqpos)))))

; lookup the position of a method in a virtual table
(defun lookup-method-in-vtable (fun vtbl)
  (values
    (position fun vtbl)
    (position-if #'(lambda (curr)
		     (and curr (functions-equivalent? curr fun))) vtbl)))