autogc.el

    

;;; autogc.el

;; Copyright (C) 2014-2015 Davin Pearson

;; Emacs Lisp Archive Entry
;; Filename: autogc.el
;; Author/Maintainer: Davin Max Pearson <http://davin.50webs.com>
;; Keywords: autogc
;; Version: 1.2

;;; Commentary:

;; This file is not part of GNU Emacs.

;;; Limitation of Warranty

;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or (at
;; your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs, see the file COPYING.  If not, see:
;;
;; <http://www.gnu.org/licenses/gpl-3.0.txt>.


;;; Known Bugs:

;; None so far!

;;; Code:

(defun autogc--are-we-editing-p (filename)
  (setq filename (expand-file-name filename))
  (let ((ptr    (buffer-list))
        (found nil))
    (while (and ptr (not found))
      (if (string= (safe-expand-file-name (buffer-file-name (car ptr))) (safe-expand-file-name filename))
          (setq found t))
      (setq ptr (cdr ptr)))
    found)
  )

(defun c++-no-fonts-mode ()
  ;;
  ;; NOTE: This mode gives the accuracy of c++-mode without the slowness of fontification
  ;;
  (interactive)
  (fundamental-mode)
  (font-lock-mode 0)
  (kill-all-local-variables)
  (setq major-mode 'c++-no-fonts-mode)
  (setq mode-name "C++ No Fonts")
  (set-syntax-table c++-mode-syntax-table)
  (use-local-map c++-mode-map)
  )

(setq number-of-errors 0)
(setq autogc--log-buffer-name "*autogc*")

;;; (switch-to-buffer autogc--log-buffer-name)
(defun autogc--error (&rest args)
  (if noninteractive
      (apply 'message args)
    (save-excursion
      (set-buffer autogc--log-buffer-name)
      (goto-char (point-max))
      (insert (apply 'format args) "\n")))
  (incf number-of-errors))

(defun autogc--combine-props-with-inheritance (prop-list subs-list)

  ;;(setq prop-list (reverse prop-list))

  (let* ((prop-list (copy-tree prop-list))
         (ptr       prop-list))

    ;;(setq dbg nil)

    (while ptr

      ;;(if (string= (caar ptr) "Array<Super>")
      ;;    (setq dbg t))

      (let* ((ptr-2      (cdar ptr))
             (whole-list ptr-2))

(while ptr-2

          ;; NOTE: (assoc KEY LIST)
          (setq ptr-3 (cdr (assoc (car ptr-2) subs-list)))
          (while ptr-3

(if (not (assoc (car ptr-3) whole-list))
                (setcdr (last ptr-2) (cons (car ptr-3) nil)))

            ;;(message "added %s" (car ptr-3))
            ;;(message "after adding whole-list=%s" whole-list)

            (setq ptr-3 (cdr ptr-3)))

(setq ptr-2 (cdr ptr-2))))
      (setq ptr (cdr ptr)))

    ;;(if dbg (debug))

    prop-list)
  )

(defun autogc--is-cyclic (prop-list)

(let* ((prop-list  (copy-tree prop-list))
         (ptr        prop-list)
         (class-name nil))
    (while ptr

(setq class-name (caar ptr))               ;; "A"

      ;; NOTE: (count KEY LIST :test 'equal)
      ;;
      ;; NOTE: detects: ("A" "A") ("A" "B" "A") etc.
      ;;
      (if (> (count class-name (car ptr) :test 'equal) 1)
          (autogc--error "*** Tight cycle detected in class %s and back again" class-name))

(let* ((ptr-2      (copy-tree (cdar ptr)))   ;; '("A" "B")
             (whole-list ptr-2))

(while ptr-2

          ;; NOTE: (assoc KEY LIST)
          (let ((ptr-3 (cdr (assoc (car ptr-2) prop-list)))) ;; ("A" "B")

            (while ptr-3

(if (equal (car ptr-3) class-name)
                  (autogc--error "*** Cycle detected in class %s to class %s and back again"
                                class-name
                                (car ptr-2)))

(if (eq (count (car ptr-3) whole-list :test 'equal) 0)
                  (setcdr (last ptr-2) (cons (car ptr-3) nil)))

(setq ptr-3 (cdr ptr-3))))
          (setq ptr-2 (cdr ptr-2))))
      (setq ptr (cdr ptr)))
    )
  )

(defun autogc--do-list (file-list)
  (when (not noninteractive)
    (if (get-buffer autogc--log-buffer-name)
        (kill-buffer autogc--log-buffer-name))
    (save-excursion
      (set-buffer (generate-new-buffer autogc--log-buffer-name))
      (compilation-mode)
      (read-only-mode -1)
      ))

(let ((number-of-errors 0))
    (autogc--error "**** Here is the list of errors")
    (autogc--error "**** ")
    (autogc-nostuff--do-all file-list)
    ;;(setq prop-list   (autogc-cycler--do-all file-list))
    ;;(setq subs-list   (autogc-inheritance--do-all file-list))
    ;;(setq mixture     (autogc--combine-props-with-inheritance prop-list subs-list))
    ;;(autogc--is-cyclic mixture)
    (autogc--error "**** End of autogc\n")
    (save-excursion
      (set-buffer autogc--log-buffer-name)
      (goto-char (point-min))
      (flush-lines "t-[0-9]+-")

(if noninteractive
          (kill-emacs (= 0 number-of-errors))
        (switch-to-buffer autogc--log-buffer-name))
      )
    )
  )

;;;
;;; NOTE: most typedefs do not need to be expanded
;;;
(defun autogc--do-me ()
  (interactive)
  (setq file-list (list (buffer-file-name)))
  (autogc--do-list file-list)
  )

(defun autogc--do-tritus ()
  (interactive)
  (progn
    (setq list1 (directory-files-deep "~/zallegro/2006/gui-menus/"      t "\\.\\(hh\\|cc\\)$"))
    (setq list2 (directory-files-deep "~/zallegro/2006/nogc2/"          t "\\.\\(hh\\|cc\\)$"))
    (setq list3 (directory-files-deep "~/zallegro/2006/Tritus-II/"      t "\\.\\(hh\\|cc\\)$"))
    (setq list4 (directory-files-deep "~/zallegro/2006/sprite-grabber/" t "\\.\\(hh\\|cc\\)$"))

(autogc--do-list (append list1 list2 list3 list4))
    )
  )

(load-library "cl")
(load-library "cl-macs")
;;(load-library "cl-seq")
(load-file (concat (car load-path) "/directory-files-deep.el"))
(load-file (concat (car load-path) "/autogc-nostuff.el"))
(load-file (concat (car load-path) "/autogc-inheritance.el"))
(load-file (concat (car load-path) "/autogc-cycler.el"))

(provide 'autogc)