; parser for converting GCC-XML file into IR

(in-package "VERRAZANO")

; the id of the root namespace
(defparameter +root-namespace-id+ "_1")

; the virtual id of the ellipses type
(defparameter +ellipsis-type-id+ "_ELLIPSIS")

; the id of the constant integer type
(defparameter +const-integer-type-id+ nil)

; types that are defined by a lexical context
(defparameter +defined-types+
  '(:|ArrayType| :|Class| :|CvQualifiedType| :|Enumeration| 
    :|FunctionType| :|FundamentalType| :|MethodType| :|Namespace| 
    :|NamespaceAlias| :|OffsetType| :|PointerType| :|ReferenceType| 
    :|Struct| :|Typedef| :|Union|))

; types that are allocated by a lexical context
(defparameter +allocated-types+
  '(:|Constructor| :|Converter| :|Destructor| :|Field| :|Function|
    :|Method| :|Variable|))

; types that require an extra indirection (through :|types|)
; when building the IR from the XML tree
(defparameter +indirect-allocated-types+
  '(:|Field| :|Variable|))

; records the state of the parser as it processes nodes
(defstruct parser-state
  xnodes
  inodes)

; parse XML file and create IR
(defun parse-gccxml-output (path)
  (let ((dom (read-xml-nodes path)))
    (convert-xml-nodes dom)))

; read XML file and return lxml DOM 
(defun read-xml-nodes (path)
  (s-xml:parse-xml-file path))

; convert from XML tree to IR graph
(defun convert-xml-nodes (dom)
  (let ((pstate (make-parser-state
		  :xnodes (index-xml-nodes dom)
		  :inodes (make-hash-table :test #'equal))))
    (create-special-nodes pstate)
    (dolist (node dom) (handle-xml-node node pstate))
    (construct-graph pstate)))

; insert some special nodes into the indices
(defun create-special-nodes (pstate)
  (let ((eltype (make-instance 'ellipsis-type)))
    (set-note eltype 'artificial t)
    (setf (gethash +ellipsis-type-id+ 
		   (parser-state-inodes pstate)) eltype))
  (maphash #'(lambda (k v)
	       (when (const-int-type? v (parser-state-xnodes pstate))
		 (setf +const-integer-type-id+ k)))
	   (parser-state-xnodes pstate)))

; create IR node for XML node, enter it into index
(defun handle-xml-node (node pstate)
  (let ((handler (lookup-handler (get-element-name node))))
    (when handler
      (funcall handler node pstate))))

; given an index of IR nodes and a queue of edges, build a graph
(defun construct-graph (pstate)
  (maphash #'(lambda (id irn)
	       (declare (ignore id))
	       (dolist (edge (node-edges irn))
		 (setf (edge-target edge) 
		       (gethash (edge-target edge)
				(parser-state-inodes pstate)))))
	   (parser-state-inodes pstate))
  (let* ((root (make-instance 'library))
	 (rns (gethash +root-namespace-id+ (parser-state-inodes pstate)))
	 (dedge (make-instance 'defines :target rns))
	 (aedge (make-instance 'allocates :target rns)))
    (set-slot aedge 'name "::")
    (add-edge root dedge)
    (add-edge root aedge)
    root))

; a macro to make it cleaner to define nodes
(defmacro with-new-node (name itype xnode pstate &rest body)
  `(let ((,name (make-instance ,itype)))
     (setf (gethash (get-element-id ,xnode) 
		    (parser-state-inodes ,pstate)) ,name)
     ,@body))

; a macro to make it easier to define edges
(defmacro with-new-edge (name itype inode to &rest body)
  `(let ((,name (make-instance ,itype :target ,to)))
     (add-edge ,inode ,name)
     ,@body))

; a wrapper over the previous macro to make target-finding easier
(defmacro with-edge-from-xml (name itype inode xnode attr &rest body)
  (let ((target (gensym)))
    `(let ((,target (get-element-attribute ,xnode ,attr)))
       (when ,target
	 (with-new-edge ,name ,itype ,inode ,target
	   ,@body)))))

; add a note to the node from an XML attribute
(defun note-from-xml (irelt name xnode attr &optional default)
  (let ((value (get-element-attribute xnode attr)))
    (when value
      (set-note irelt name value default))))

; add a slot to the node from an XML attribute
(defun slot-from-xml (irelt slot xnode attr &optional default)
  (let ((value (get-element-attribute xnode attr)))
    (when value
      (set-slot irelt slot value default))))

; make a generic function node
(defmacro with-function-type (irn node pstate &rest body)
  `(with-new-node ,irn 'function-type ,node ,pstate
     (slot-from-xml  ,irn 'name ,node ':|name|)
     (add-edges-to-arguments ,irn ,node ,pstate)
     ,@body))

; index xml nodes by their id attribute
(defun index-xml-nodes (dom)
  (let ((index (make-hash-table :test #'equal)))
    (dolist (node dom index)
      (let ((id (get-element-id node)))
	(when id
	  (setf (gethash id index) node))))))

; is a given XML node the "const int" type?
(defun const-int-type? (node xml-index)
  (when (and (eq (get-element-name node) ':|CvQualifiedType|)
	     (equal (get-element-attribute node ':|const|) "1"))
    (let ((tgt (gethash (get-element-attribute node ':|type|) xml-index)))
      (when (equal (get-element-attribute tgt ':|name|) "int") t))))