; utility routines for the front-end

(in-package "VERRAZANO")

; run a shell command with redirected output portably
(defun run-redirected (cmd out)
  #+allegro (excl:run-shell-command cmd :output out)
  #-allegro (asdf:run-shell-command (format nil "~A > \"~A\"" cmd out)))

; convert a size from bits to bytes
(defun bits-to-bytes (nr)
  (/ nr 8))

; return true of argument is not nil
(defun non-nil? (arg) arg)

; return a list of all elements in list satisfying pred
(defun find-all (pred lst)
  (remove-if-not pred lst))

; check if a string starts with a given prefix
(defun starts-with (pfx str)
  (eq 0 (search pfx str)))

; check if a string ends with a given prefix
(defun ends-with (pfx str) 
  (eq (- (length str) (length pfx)) (search pfx str)))

; recursively strip nils from a tree
(defun strip-nils (lst)
  (if (listp lst)
    (remove nil (mapcar #'strip-nils lst))
    lst))

; convert C constant syntax to Lisp constant syntax
(defun c-constant-to-lisp (str)
  (cond
    ((starts-with "0x" str)
     (concatenate 'string "#x" (subseq str 2 nil)))
    (t str)))
  
; check for match if second arg is not nil
(defun match-optional (value check)
  (or (not check) (eq value check)))

; push an element onto the end of a list
(defmacro push-end (value lst)
  `(setf ,lst (append ,lst (list ,value))))

; insert an element into a list iff it doesn't exist
(defmacro push-unique (element lst)
  `(when (not (member ,element ,lst))
     (push ,element ,lst)))

; extend a list with another list
(defmacro push-extend (value lst)
  `(setf ,lst (append ,lst ,value)))

; put quotes around a string
(defun quote-string (str)
  (concatenate 'string (concatenate 'string "\"" str) "\""))

; unquote a string
(defun unquote-string (str)
  (if (and
	  (eq (elt str 0) #\")
	  (eq (elt str (- (length str) 1)) #\"))
    (subseq str 1 (- (length str) 1))
    str))

; does a string contain a space?
(defun contains-space? (str)
  (find #\Space str))

; get the element after an element in the sequence
(defun element-after (seq key)
  (let ((pos (position key seq)))
    (when pos
      (elt seq (+ 1 pos)))))

; set the element after an element in the sequence
(defun set-element-after (seq key val)
  (let ((pos (position key seq)))
    (when pos
      (setf (elt seq (+ 1 pos)) val))))

; get the ID attribute of an XML node
(defun get-element-id (node)
  (get-element-attribute node ':|id|))

; return the name of the xml element in lxml format
(defun get-element-name (node)
  (if (not (listp node))
    node
    (if (not (listp (car node)))
      (car node)
      (caar node))))

; return value of attribute of node in lxml format
(defun get-element-attribute (node attr)
  (when (listp node)
    (if (listp (car node))
      (element-after (car node) attr)
      (element-after node attr))))

; set the value of an attribute in lxml format
(defun set-element-attribute (node attr val)
  (when (listp node)
    (if (listp (car node))
      (set-element-after (car node) attr val)
      (set-element-after node attr val))))

; return the given attribute value as in integer
(defun get-element-attribute-int (node attr)
  (parse-integer (get-element-attribute node attr)))

; return the children of a node in lxml format
(defun get-element-children (node)
  (when (and (listp node) (listp (car node)))
    (remove-if #'stringp (cdr node))))

; split a list of ids
(defun split-id-list (str)
  (split-sequence #\Space str))

; a monotonic counter (not thread-safe!)
(defparameter *monotonic-counter* 0)

; get the next counter value
(defun get-next-integer ()
  (incf *monotonic-counter*))

; print the IR in topological order from the root
(defun print-ir (root)
  (print-ir-helper root 0)
  (unmark-graph root))

(defun print-ir-helper (root indent)
  (when (and root (not (node-mark root)))
    (print-element root indent)
    (mark-node root)
    (dolist (edge (node-edges root))
      (print-element edge (+ 1 indent)))
    (dolist (edge (node-edges root))
      (print-ir-helper (edge-target edge) (+ 1 indent)))))  

; print an element's string-representation
(defun print-element (node indent)
  (format t "~A ~A~%" indent (string-representation node)))

; return a string representation of the IR element
(defgeneric string-representation (element))

(defmethod string-representation (element)
  (format nil "~A" element))

(defmethod string-representation ((element cpp-type))
  (format nil "~A ~A" (type-of element) 
	  (named-name element)))

(defmethod string-representation ((element edge))
  (format nil "    ~A ~A" (type-of element)
	  (string-representation (edge-target element))))

(defmethod string-representation ((element allocates))
  (format nil "    ~A ~A named ~A" (type-of element)
	  (string-representation (edge-target element)) 
	  (named-name element)))

(defmethod string-representation ((element receives))
  (format nil "    ~A ~A named ~A with index ~A" (type-of element)
	  (string-representation (edge-target element))
	  (named-name element)
	  (receives-edge-index element)))

; print an ordered list of definitions
(defun print-definition-queue (queue)
  (dolist (element queue)
    (let ((from (car element))
	  (edge (cadr element))
	  (to (caddr element)))
      (format t "~A: ~A ~A~%" 
	      (node-order to)
	      (string-representation from)
	      (string-representation edge)))))

; print the vtables of all classes in the IR
(defun print-class-vtables (ir)
  (format t "~%")
  (apply-to-nodes #'print-class-vtable ir))

; print the vtables of a class
(defun print-class-vtable (node)
  (when (composite-type? node)
    (let ((vtbl (get-note node 'virtual-table)))
      (when vtbl
	(format t "~%v-table for class ~A~%" (named-name node))
	(dolist (vtent vtbl)
	  (if (not vtent)
	    (format t "    RTTI or OTT Entry~%")
	    (format t "    ~A~%" (named-name vtent))))))))

; print the base classes of all classes
(defun print-class-bases (ir)
  (format t "~%")
  (apply-to-nodes #'print-bases-for-class ir))

; print the bases of a given class
(defun print-bases-for-class (node)
  (when (composite-type? node)
    (format t "~%Bases of ~A: " (named-name node))
    (dolist (base (all-adjacent-nodes node '(extends)))
      (format t "~A " (named-name base)))))