; parser for converting GCC-XML file into IR

(in-package "VERRAZANO")

; the id of the root namespace
(defparameter +root-namespace-id+ nil)

; a reference to the root namespace
(defparameter +root-namespace-ref+ nil)

; 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)

; a reference to the constant integer type
(defparameter +const-integer-type-ref+ nil)

; the id of the void type
(defparameter +void-type-id+ nil)

; a reference to the void type
(defparameter +void-type-ref+ nil)

; fields that indicate that one XML nodes refers to another
(defparameter +reference-attributes+
  '(:|context| :|members| :|returns| :|type|))

; types that can be broken up during culling
(defparameter +seperable-types+
  '(:|Namespace|))

; 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| :|Constructor| :|Converter|
    :|Destructor| :|Function| :|Method|))

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

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

; types that don't have a context field
(defparameter +undefined-types+
  '(:|CvQualifiedType| :|FundamentalType| :|PointerType| :|ReferenceType|))

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

; parse XML file and create IR
(defun parse-gccxml-output (cfg path macpath)
  (let* ((dom (read-xml-nodes path))
	 (macs (read-macros macpath)))
    (convert-to-ir cfg dom macs)))

; read XML file and return lxml DOM 
(defun read-xml-nodes (path)
  (handler-case (s-xml:parse-xml-file (namestring path))
    (file-error () (error 'gccxml-error))))

; read macro definitions from the macro file
(defun read-macros (path)
  (let ((macs nil))
    (with-open-file (in path :direction :input :if-exists :supersede)
      (loop for line = (read-line in nil 'eof)
	    until (eq line 'eof)
	    do (push-end (split-sequence #\Space line) macs)))
    macs))

; convert from XML tree and macro list to IR graph
(defun convert-to-ir (cfg dom macs)
  (let ((pstate (make-parser-state
		  :xnodes (index-xml-nodes dom)
		  :inodes (make-hash-table :test #'equal))))
    (find-root-files cfg pstate)
    (create-special-nodes pstate)
    (create-macro-nodes pstate macs)
    (prune-unreachable-nodes pstate)
    (dolist (node dom) (handle-xml-node node pstate))
    (lookup-special-nodes pstate)
    (construct-graph pstate)))

; prune nodes in the XML tree unreachable from main headers
(defun prune-unreachable-nodes (pstate)
  (let ((reachable (make-hash-table))
	(visited (make-hash-table)))
    (protect-special-nodes reachable)
    (maphash #'(lambda (k v)
		 (declare (ignore k))
		 (let ((fl (get-element-attribute v ':|file|)))
		   (when (member fl (parser-state-root-files pstate)
				 :test #'equal)
		     (mark-reachable v reachable visited pstate))))
	     (parser-state-xnodes pstate))
    (maphash #'(lambda (k v)
		 (when (not (gethash v reachable))
		   (remhash k (parser-state-xnodes pstate))))
	     (parser-state-xnodes 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 (root-namespace? v (parser-state-xnodes pstate))
		 (setf +root-namespace-id+ k)))
	   (parser-state-xnodes pstate))
  (maphash #'(lambda (k v)
	       (when (void-type? v (parser-state-xnodes pstate))
		 (setf +void-type-id+ k)))
	   (parser-state-xnodes pstate))
  (maphash #'(lambda (k v)
	       (when (const-int-type? v (parser-state-xnodes pstate))
		 (setf +const-integer-type-id+ k)))
	   (parser-state-xnodes pstate)))

; lookup a few special IR nodes and record references to them
(defun lookup-special-nodes (pstate)
  (setf +root-namespace-ref+ 
	(gethash +root-namespace-id+ (parser-state-inodes pstate)))
  (setf +const-integer-type-ref+
	(gethash +const-integer-type-id+ (parser-state-inodes pstate)))
  (setf +void-type-ref+
	(gethash +void-type-id+ (parser-state-inodes 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))))

; create macro nodes derived from the preprocessor
(defun create-macro-nodes (pstate macs)
  (let ((cf nil))
    (dolist (mac macs)
      (let* ((op (car mac))
	     (fl (caddr mac)))
	(when (equal op "#")
	  (setf cf (translate-gccxml-filename (unquote-string fl) pstate)))
	(create-macro-node mac pstate cf)))))

; create the macro node for a given macro definition
(defun create-macro-node (mac pstate curr-file)
  (let* ((op (car mac))
	 (sym (cadr mac))
	 (val (cddr mac))
	 (cval (convert-macro-value val))
	 (rns (gethash +root-namespace-id+ (parser-state-xnodes pstate))))
    (when (and cval (equal op "#define"))
      (let ((id (format nil "_VZN~A" (get-next-integer))))
	(setf (gethash id (parser-state-xnodes pstate))
	      `((:|Variable| :|id| ,id :|name| ,sym :|init| ,cval
		 :|context| "_1" :|file| ,curr-file
		 :|type| ,+const-integer-type-id+)))
	(set-element-attribute rns ':|members|
          (concatenate 'string 
		       (get-element-attribute rns ':|members|) " " id))))))

; 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))
	 (dedge (make-instance 'defines 
			       :target +root-namespace-ref+))
	 (aedge (make-instance 'allocates 
			       :target +root-namespace-ref+ 
			       :name "::")))
    (append-edge root dedge)
    (append-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)))
     (append-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)))
    (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 (and value (subtypep (type-of default) 'integer))
      (setf value (parse-integer value)))
    (set-slot irelt slot value default)))

; a function to ease handling of real/mangled names
(defun name-from-xml (irelt xnode)
  (slot-from-xml irelt 'name xnode ':|name|)
  (slot-from-xml irelt 'c-name xnode ':|mangled| 
		 (get-element-attribute xnode ':|name|)))

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

; make a generic concrete type
(defmacro with-concrete-type (irn irtype node pstate &rest body)
  `(with-new-node ,irn ,irtype ,node ,pstate
     (slot-from-xml ,irn 'size ,node ':|size| 0)
     (slot-from-xml ,irn 'align ,node ':|align| 0)
     ,@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))))))

; find the files referred to directly by the input file
(defun find-root-files (cfg pstate)
  (setf (parser-state-file-ids pstate)
	(make-hash-table :test #'equal))
  (maphash #'(lambda (k v)
	       (let ((name (get-element-attribute v ':|name|))
		     (tp (get-element-name v)))
		 (when (eq tp ':|File|)
		   (setf (gethash name (parser-state-file-ids pstate)) k)
		   (when (root-set-member? name cfg)
		     (push k (parser-state-root-files pstate))))))
	   (parser-state-xnodes pstate)))

; is a file a member of the root set?
(defun root-set-member? (fil cfg)
  (member-if #'(lambda (f)
		 (ends-with f fil))
	     (configuration-included-files cfg)))

; translate from a file name to file id
(defun translate-gccxml-filename (fname pstate)
  (gethash fname (parser-state-file-ids pstate)))

; protect certain special type nodes from being pruned
(defun protect-special-nodes (reachable)
  (setf (gethash +root-namespace-id+ reachable) t)
  (setf (gethash +ellipsis-type-id+ reachable) t)
  (setf (gethash +const-integer-type-id+ reachable) t)
  (setf (gethash +void-type-id+ reachable) t))
		     
; mark root as reachable, all nodes reachable from root as reachable
(defun mark-reachable (root reachable visited pstate)
  (when (not (gethash root visited))
    (setf (gethash root visited) t)
    (setf (gethash root reachable) t)
    (dolist (one (nodes-reachable-from root pstate))
      (mark-reachable one reachable visited pstate))))

; get all the nodes reachable from a given node
(defun nodes-reachable-from (root pstate)
  (when (not (member (get-element-name root) +seperable-types+))
    (let ((nodes nil))
      (dolist (attr +reference-attributes+)
	(dolist (id (split-id-list (get-element-attribute root attr)))
	  (push (gethash id (parser-state-xnodes pstate)) nodes)))
      (dolist (child (get-element-children root) nodes)
	(push-extend (nodes-reachable-from child pstate) nodes)))))

; make a name for a function-type object
(defun make-function-type-name (node)
  (let ((oname (get-element-attribute node ':|name|)))
    (when oname
      (concatenate 'string oname "-type"))))

; is a given XML node a namespace node?
(defun namespace-node? (node)
  (eq (get-element-name node) ':|Namespace|))

; is a given XML node the root namespace?
(defun root-namespace? (node xml-index)
  (declare (ignore xml-index))
  (and (namespace-node? node)
       (equal (get-element-attribute node ':|name|) "::")))

; 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)))
      (equal (get-element-attribute tgt ':|name|) "int"))))

; is a given XML node the "void" type?
(defun void-type? (node xml-index)
  (declare (ignore xml-index))
  (and (eq (get-element-name node) ':|FundamentalType|)
       (equal (get-element-attribute node ':|name|) "void")))

; convert a macro value to a Lisp value
(defun convert-macro-value (val)
  (and (listp val)
       (eq (length val) 1)
       (handler-case (parse-number 
		       (c-constant-to-lisp (car val)))
	 (t () nil))))

; determine type of macro value
(defun macro-value-type-id (val)
  (declare (ignore val))
  +const-integer-type-id+)