/; a list of parser handlers

(in-package "VERRAZANO")

; map of handlers for driving the parser
(defparameter +handler-map+
  '((:|ArrayType|        . handle-array-type)
    (:|Class|            . handle-class)
    (:|Constructor|      . handle-constructor)
    (:|Converter|        . handle-converter)
    (:|CvQualifiedType|  . handle-cv-qualified-type)
    (:|Destructor|       . handle-destructor)
    (:|Enumeration|      . handle-enumeration)
    (:|Function|         . handle-function)
    (:|FunctionType|     . handle-function-type)
    (:|FundamentalType|  . handle-fundamental-type)
    (:|Method|           . handle-function)
    (:|MethodType|       . handle-function-type)
    (:|Namespace|        . handle-namespace)
    (:|NamespaceAlias|   . handle-namespace-alias)
    (:|OperatorFunction| . handle-operator)
    (:|OperatorMethod|   . handle-operator)
    (:|PointerType|      . handle-pointer-type)
    (:|ReferenceType|    . handle-pointer-type)
    (:|Struct|           . handle-class)
    (:|Typedef|          . handle-typedef)
    (:|Union|            . handle-union)))

; lookup the handler for a given XML element
(defun lookup-handler (element)
  (cdr (assoc element +handler-map+)))

; add edges to all the bases of a given node
(defun add-edges-to-bases (irn node pstate)
  (declare (ignore pstate))
  (dolist (base (get-element-children node))
    (with-edge-from-xml ire 'extends irn base ':|type|
      (slot-from-xml ire 'virtual base ':|virtual|))))

; add edges to all the members of a given node
(defun add-edges-to-members (irn node pstate)
  (dolist (to (split-id-list (get-element-attribute node ':|members|)))
    (let* ((tonode (gethash to (parser-state-xnodes pstate)))
	   (totype (get-element-name tonode)))
      (unless (and (namespace-node? node) (not tonode))
	(when (member totype +defined-types+)
	  (add-edge-to-defined irn tonode))
	(when (member totype +allocated-types+)
	  (if (member totype +indirect-allocated-types+)
	    (add-edge-to-indirect irn tonode)
	    (add-edge-to-direct irn tonode)))))))

; add an edge to a defined type
(defun add-edge-to-defined (irn tonode)
  (with-new-edge ire 'defines irn (get-element-id tonode)))

; add an edge to an indirectly-allocated type
(defun add-edge-to-indirect (irn tonode)
  (add-edge-to-allocated irn tonode (get-element-attribute tonode ':|type|)))

; add an edge to a directly-allocated type
(defun add-edge-to-direct (irn tonode)
  (add-edge-to-allocated irn tonode (get-element-id tonode)))

; add an edge to an allocated type
(defun add-edge-to-allocated (irn tonode target)
  (with-new-edge ire 'allocates irn target
    (name-from-xml ire tonode)
    (slot-from-xml ire 'value tonode ':|init|)
    (when (get-element-attribute tonode ':|offset|)
      (slot-from-xml ire 'offset tonode ':|offset|) 0)
    (when (get-element-attribute tonode ':|virtual|)
      (slot-from-xml ire 'virtual tonode ':|virtual|))))

; add edges to the arguments of a function-type
(defun add-edges-to-arguments (irn node pstate)
  (declare (ignore pstate))
  (if (not (get-element-attribute node ':|returns|))
    (with-new-edge ire 'returns irn +void-type-id+)
    (with-edge-from-xml ire 'returns irn node ':|returns|))
  (dolist (arg (get-element-children node))
    (with-new-edge ire 'receives irn (lookup-argument-type arg)
      (name-from-xml ire arg)
      (slot-from-xml ire 'value arg ':|default|))))

; lookup the type of an argument, handling Ellipsis elements
(defun lookup-argument-type (node)
  (let ((name (get-element-name node)))
    (if (eq ':|Ellipsis| name)
      +ellipsis-type-id+
      (get-element-attribute node ':|type|))))

; add edges to the values of an enumeration
(defun add-edges-to-values (irn node pstate)
  (declare (ignore pstate))
  (dolist (valnode (get-element-children node))
    (with-new-edge ire 'allocates irn +const-integer-type-id+
      (name-from-xml ire valnode)
      (slot-from-xml ire 'value valnode ':|init|))))

; add edges to types that aren't defined in any namespace
(defun add-edges-to-undefined (irn node pstate)
  (declare (ignore node))
  (maphash #'(lambda (key val)
	       (when (member (get-element-name val) +undefined-types+)
		 (with-new-edge ire 'defines irn key)))
	   (parser-state-xnodes pstate)))

; handle ArrayType XML elements
(defun handle-array-type (node pstate)
  (with-new-node irn 'array-type node pstate
    (slot-from-xml irn 'length node ':|max|)
    (with-edge-from-xml ire 'extends irn node ':|type|)))

; handle Class XML elements
(defun handle-class (node pstate)
  (with-concrete-type irn 'class-type node pstate
    (name-from-xml irn node)
    (add-edges-to-bases irn node pstate)
    (add-edges-to-members irn node pstate)))

; handle Constructor XML elements
(defun handle-constructor (node pstate)
  (with-function-type irn node pstate
    (set-note irn 'role 'constructor)))

; handle Converter XML elements
(defun handle-converter (node pstate)
  (with-function-type irn node pstate
    (set-note irn 'role 'converter)))

; handle CvQualifiedType XML elements
(defun handle-cv-qualified-type (node pstate)
  (with-new-node irn 'qualified-type node pstate
    (slot-from-xml irn 'const node ':|const|)
    (with-edge-from-xml ire 'extends irn node ':|type|)))

; handle Destructor XML elements
(defun handle-destructor (node pstate)
  (with-function-type irn node pstate
    (set-note irn 'role 'destructor)))

; handle Enumeration XML elements
(defun handle-enumeration (node pstate)
  (with-concrete-type irn 'enum-type node pstate
    (name-from-xml irn node)
    (add-edges-to-values irn node pstate)))

; handle Function, Method XML elements
(defun handle-function (node pstate)
  (with-function-type irn node pstate
    (note-from-xml irn 'static node ':|static|)
    (set-note irn 'role 'none)
    (set-note irn 'artificial t)))

; handle FunctionType, MethodType XML elements
(defun handle-function-type (node pstate)
  (with-function-type irn node pstate
    (set-note irn 'role 'none)))

; handle FundamentalType XML elements
(defun handle-fundamental-type (node pstate)
  (with-concrete-type irn 'fundamental-type node pstate
    (name-from-xml irn node)))

; handle Namespace XML elements
(defun handle-namespace (node pstate)
  (with-new-node irn 'namespace-type node pstate
    (name-from-xml irn node)
    (add-edges-to-members irn node pstate)
    (when (equal (get-element-id node) +root-namespace-id+)
      (add-edges-to-undefined irn node pstate))))

; handle NamespaceAlias XML elements
(defun handle-namespace-alias (node pstate)
  (with-new-node irn 'alias-type node pstate
    (name-from-xml irn node)
    (with-edge-from-xml ire 'extends irn node ':|namespace|)))

; handle OperatorFunction, OperatorMethod XML elements
(defun handle-operator (node pstate)
  (with-function-type irn node pstate
    (set-note irn 'role 'operator)))

; handle PointerType XML elements
(defun handle-pointer-type (node pstate)
  (with-concrete-type irn 'pointer-type node pstate
    (with-edge-from-xml ire 'extends irn node ':|type|)))

; handle Typedef XML elements
(defun handle-typedef (node pstate)
  (with-new-node irn 'alias-type node pstate
    (name-from-xml irn node)
    (with-edge-from-xml ire 'extends irn node ':|type|)))

; handle Union XML elements
(defun handle-union (node pstate)
  (with-concrete-type irn 'union-type node pstate
    (name-from-xml irn node)
    (add-edges-to-members irn node pstate)))