;;
;; This is the core part of a tool to produce a graphical
;; representation of VOP argument lifetimes.  As yet, it is more than
;; a few rough edges, and is not anywhere near being the tool that the
;; author would like to have.
;;


;; Still to do:
;;
;;   Making motion within the buffer work.
;;
;;   Editing the specs.
;;
;;   Writing updated specs back to the source (C-c C-c?).
;;
;;   Making a "quit" key (q?) to close the window.

(defvar voplife-mode-map
  (let ((map (make-keymap)))
    (suppress-keymap map)
    map)
  "Keymap for VOP lifetime editing mode.")

(put 'voplife-mode 'mode-class 'special) ;; Custom-formatted contents.

(defun voplife-mode ()
  "A major mode for editing VOP lifetimes."
  (kill-all-local-variables)
  (setq major-mode 'voplife-mode)
  (setq mode-name "VOP Lifetime")
  (setq buffer-read-only t)
  (make-local-variable 'voplife-specs)
  (make-local-variable 'voplife-time-offsets)
  ;(run-mode-hooks 'voplife-mode-hook)
  )

(defun voplife-write-header-and-find-offsets (initial-offset times)
  (let ((current-offset (+ initial-offset 2))
        (offsets nil))
    (push (cons :beginning current-offset) offsets)
    (dolist (time times)
      (princ "  ")
      (let ((time-string (with-output-to-string (princ time))))
        (push (cons time (+ current-offset
                            (floor (length time-string) 2)
                            1))
              offsets)
        (setq current-offset (+ current-offset (length time-string) 2)))
      (princ time))
    (push (cons :end (1- current-offset)) offsets)
    (setq voplife-time-offsets offsets)
    offsets))

(defun voplife-write-lifetime (offsets spec)
  (let* ((start-time (plist-get (cdr spec) :from))
	 (end-time (plist-get (cdr spec) :to))
	 (start-pos (cdr (assoc start-time offsets)))
	 (end-pos (cdr (assoc end-time offsets))))
    (terpri)
    (princ (car spec))
    (princ ":")
    (princ (make-string (- start-pos (length (symbol-name (car spec))) 1) ? ))
    (princ (if (eq start-time :beginning) "-" "|"))
    (princ (make-string (- end-pos start-pos 1) ?-))
    (princ (if (eq end-time :end) "-" "|"))))

(defun voplife-collect-times (specs)
  "Grovel over SPECS, collecting the total set of times used."
  (let ((times nil))
    (dolist (spec specs)
      (add-to-list 'times (plist-get (cdr spec) :from))
      (add-to-list 'times (plist-get (cdr spec) :to)))
    (delq :beginning (delq :end times))))

(defun voplife-time-< (t1 t2)
  "Compare time-specs T1 and T2, returning true if T1 is prior to T2."
  (let ((base1 (if (consp t1) (car t1) t1))
	(base2 (if (consp t2) (car t2) t2)))
    (if (eq base1 base2)
	;; If the bases are equal, then they have an integer sub-phase.
	(< (cadr t1) (cadr t2))
      (let ((time-order '(:beginning :load :argument :eval :result :save :end)))
	;; Barring finding anything more likable, we have to use memq
	;; here.  Start by finding base1 in the time-order.  If base2
	;; is then findable in the list starting at base1, t1 is less
	;; than t2.  I'd rather have used POSITION, but it doesn't
	;; appear to be in elisp.
	(memq base2 (memq base1 time-order))))))

(defun voplife-sort-times (times)
  "Sort (destructively) the list of time-specs TIMES into
chronological order."
  (sort times #'voplife-time-<))

(defun voplife-graph-lifetimes (specs)
  (let ((name-width (apply #'max (mapcar (lambda (spec)
					   (length (symbol-name (car spec))))
					 specs))))
    (princ (make-string (1+ name-width) ? ))
    (let* ((times (voplife-sort-times (voplife-collect-times specs))))
      (voplife-write-header-and-find-offsets name-width times)
      (dolist (spec specs)
	(voplife-write-lifetime voplife-time-offsets spec)))))

(defun voplife-update-buffer (buffer)
  "Update the buffer, based on VOPLIFE-SPECS."
  (save-excursion
    (set-buffer buffer)
    (let ((buffer-read-only nil)
          (standard-output buffer))
      (erase-buffer)
      (voplife-graph-lifetimes voplife-specs))
    (set-buffer-modified-p nil)))

(defun voplife-test-function ()
  "A test function for VOPLIFE"
  (interactive)
  (let ((specs nil)
        (vop-name nil))
    (save-excursion
      (beginning-of-defun)
      (if (not (looking-at "(define-vop "))
          (error "Not within a VOP definition.")
        (forward-char)
        (forward-sexp) ;; Skip "define-vop".
        ;; Now looking at a list of the VOP name and possible inheritee.
        ;; If we want to grab the VOP name, now's the time... under
        ;; save-excursion, of course.
        (if (not (looking-at "[[:blank:]]+(\\([A-Za-z$%&_-]+\\)[:space:]*\\w*)"))
            (error "Unable to parse VOP name."))
        (setq vop-name (match-string 1))
        (while (condition-case err
                   (progn
                     ;; Two steps forward, one step back, so we end up
                     ;; with the point on the open-paren.
                     (forward-sexp)
                     (forward-sexp)
                     (backward-sexp)
                     t)
                 (error nil))
          ;; Now at the first character of a SPEC (the open-paren).  We
          ;; want to snarf :ARGS, :RESULTS and :TEMPORARY SPECs.
          (cond
           ((looking-at "(:args")
            ;; FIXME: Parse for args.
            (save-excursion
              (let ((args-spec (read (current-buffer)))
                    (index 0))
                (dolist (arg (cdr args-spec))
                  (push `(,(car arg) :from :beginning
                          :to ,(or (plist-get (cdr arg) :to)
                                   `(:argument ,index)))
                        specs)
                  (setq index (+ index 1)))))
            )
           ((looking-at "(:results")
            ;; FIXME: Parse for results.
            (save-excursion
              (let ((results-spec (read (current-buffer)))
                    (index 0))
                (dolist (result (cdr results-spec))
                  (push `(,(car result) :to :end
                          :from ,(or (plist-get (cdr result) :from)
                                     `(:result ,index)))
                        specs)
                  (setq index (+ index 1))))))
           ((looking-at "(:temporary")
            ;; FIXME: Parse for a temporary.
            (save-excursion
              (let ((temp-spec (read (current-buffer))))
                (push `(,(car (cddr temp-spec))
                        :from ,(or (plist-get (cadr temp-spec) :from) :load)
                        :to ,(or (plist-get (cadr temp-spec) :to) :save))
                      specs))))))
        ;(print specs)
        (let ((buffer-name (concat "VOP " vop-name " Lifetimes")))
          (set-buffer (get-buffer-create buffer-name))
          (voplife-mode)
          (let* ((pop-up-windows t)
                 (split-height-threshold 1000))
            (pop-to-buffer buffer-name)
            (setq voplife-specs (nreverse specs))
            (voplife-update-buffer (get-buffer buffer-name))
            (fit-window-to-buffer nil nil 2)))
        ))))

;; An example of use:

;;(voplife-graph-lifetimes '((arg0 :from :beginning :to (:argument 0))
;;			   (arg1 :from :beginning :to (:argument 1))
;;			   (temp :from (:argument 0) :to :save)
;;			   (result :from :load :to :end)))

;;(let ((standard-output t))
;;  (voplife-graph-lifetimes '((result :to :end :from (:result 0))
;;                           (diff :from :beginning :to (:argument 2))
;;                           (index :from :beginning :to (:argument 1))
;;                           (array :from :beginning :to (:argument 0)))))