; functions that implement various policies

(in-package "VERRAZANO")

; various special names that must be converted
(defparameter +special-names+
  '(("t" . "xt")
    ("nil" . "xnil")))

; policy for naming anonymous-nodes
(defgeneric name-anonymous (irn))

; policy for translating c-names
(defgeneric translate-name (irn))

; policy for resolving conflicts created by casing
(defgeneric recase-namespace (ns))

; policy for combining name of parent and child
(defgeneric combine-name (parent edge child))

; policy for naming a converter function
(defgeneric name-converter (fun to))

; policy for naming an operator function
(defgeneric name-operator (fun))

; policy for mapping constructors
(defgeneric name-constructor (fun))

; policy for mapping destructors
(defgeneric name-destructor (fun))

; default implementation of naming anonymous element
(defmethod name-anonymous (element)
  (setf (named-name element)
	(concatenate 'string "anonymous" 
		     (princ-to-string (get-next-integer)))))

; default implementation of name translation
(defmethod translate-name (element)
  (let ((strans (assoc (named-name element) +special-names+ :test #'equal)))
    (when strans
      (setf (named-name element) (cdr strans))))
  (setf (named-name element)
	(string-downcase (substitute #\- #\_ (named-name element)))))

; default implementation of resolving casing conflicts
(defmacro resolve-conflicts (element table)
  (let ((name (gensym))
	(counter (gensym)))
    `(let* ((,name (named-name ,element))
	    (,counter (gethash (string-downcase ,name) ,table)))
       (if ,counter
	 (progn
	   (setf (named-name ,element) 
		 (format nil "~A-~A" ,name ,counter))
	   (setf (gethash (string-downcase ,name) ,table)
		 (+ ,counter 1)))
	 (setf (gethash (string-downcase ,name) ,table) 1)))))

(defmethod recase-namespace (ns)
  (let ((funs-seen (make-hash-table :test #'equal))
	(vars-seen (make-hash-table :test #'equal)))
    (dolist (edge (node-edges ns))
      (cond
	((function? edge) (resolve-conflicts edge funs-seen))
	((allocates-edge? edge) (resolve-conflicts edge vars-seen))
	((defines-edge? edge) 
	   (resolve-conflicts (edge-target edge) vars-seen))))))

; default implementation of name combining
(defmethod combine-name (parent edge child)
  (combine-element-name parent edge)
  (combine-element-name parent child))

; helper method for combine-name
(defun combine-element-name (p c)
  (when (subtypep (type-of c) 'named)
    (setf (named-name c)
	  (concatenate 'string 
		       (named-name p) "-" (named-name c)))))

; default implementation of converter naming
(defmethod name-converter (fun to)
  (setf (named-name fun)
	(concatenate 'string "to-" (named-name to)))) 

; default implementation of operator naming
(defmethod name-operator (fun)
  (setf (named-name fun) 
	(concatenate 'string "operator" (named-name fun))))

; default implementation of constructor naming
(defmethod name-constructor (fun)
  (setf (named-name fun) "new"))

; default implementation of destructor naming
(defmethod name-destructor (fun)
  (setf (named-name fun) "delete"))