autogc-inheritance.el

    

;;; autogc-inheritance.el

;; Copyright (C) 2014-2015 Davin Pearson

;; Emacs Lisp Archive Entry
;; Filename: autogc-inheritance.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-inheritance--get-superclass-list ()
  (beginning-of-line)
  (let (answer)
    ;;
    ;; NOTE: currently multiple inheritance is not supported
    ;;
    (if (re-search-forward ":"
                           (point-at-eol)
                           t)
        (progn
          (skip-chars-forward " ")
          (cond
           ((looking-at "public")
            (autogc-cycler--skip-literal "public")
            (skip-chars-forward " "))
           ((looking-at "private")
            (autogc-cycler--skip-literal "private"))
           ((looking-at "protected")
            (autogc-cycler--skip-literal "protected"))
           )
          (setq answer (autogc-cycler--gulp-identifier))
          (beginning-of-line)
          (forward-line 1)
          answer)
      (beginning-of-line)
      (forward-line 1)
      nil)))

;;;
;;; NOTE: in the game each class has a single superclass (i.e. no
;;; multiple inheritance) but each class can have many subclasses...
;;;
(defun autogc-inheritance--get-class-superclasses (file-list)
  (let ((ptr              file-list)
        (answer           nil)
        (class-name       nil)
        (superclass-list  nil))

(while ptr

(let ((auto-mode-alist (cons '("" . c++-no-fonts-mode) auto-mode-alist)))
        ;;(setq were-editing (autogc--are-we-editing-p (car ptr)))
        ;;(save-buffer (find-file-read-only (car ptr))))
        (find-file-read-only (car ptr)))

(goto-char (point-min))
      (while (re-search-forward "^class " nil t)
        (setq class-name (autogc-cycler--gulp-identifier))
        (setq superclass-list (autogc-inheritance--get-superclass-list))
        (if superclass-list
            (setq answer (cons (list class-name superclass-list) answer))))

      ;;(if were-editing
      ;;    (setq buffer-read-only nil)
      (kill-buffer nil)

(setq ptr (cdr ptr)))
    (reverse answer)))

;;; (autogc-inheritance--get-subclasses superclasses-list)
;;; (setq fixed-subclass-list (autogc-inheritance--get-subclasses (autogc-inheritance--get-class-superclasses '("d:/t-cycler/a.cc" "d:/t-cycler/b.cc"))))
(defun autogc-inheritance--get-subclasses (superclasses-list)
  (let ((ptr    superclasses-list)
        (answer nil))
    (while ptr
      (let ((ptr2 (cdar ptr))
            (a    nil))

(while ptr2

(setq a (assoc (car ptr2) answer))

(if a
              (progn
                ;;(debug)
                (setcdr (last a) (cons (caar ptr) nil)))

(setq answer (cons (list (car ptr2) (caar ptr)) answer)))

(setq ptr2 (cdr ptr2))))
      (setq ptr (cdr ptr)))
    (reverse answer)))

;;;
;;; (setq fixed-subclass-list (autogc-inheritance--get-subclasses (autogc-inheritance--get-class-superclasses '("d:/t-cycler/a.cc" "d:/t-cycler/b.cc"))))
;;; (setq ans (autogc-inheritance--get-all-subclasses fixed-subclass-list))
;;;
(defun autogc-inheritance--get-all-subclasses (fixed-subclass-list)
  ;;
  ;; NOTE: copy-sequence doesn't work here...
  ;;
  (let* ((answer-list (copy-tree fixed-subclass-list))
         (ptr         answer-list))

(while ptr
      ;;(debug)
      (let ((ptr-2      (cdar ptr))
            (superclass (caar ptr)))

        ;;(debug)
        (while ptr-2

(let* ((cur (car ptr-2))
                   (a   (assoc cur answer-list)))

              ;;(debug)
              (when a
                (let ((ptr-3 (cdr a)))
                  (while ptr-3

                    ;;(debug)
                    (when (not (eq 0 (count
                                      (car ptr-3)
                                      (cdr (assoc superclass answer-list))
                                      :test 'equal)))

                      ;; TODO: more details of error message needed

                      (debug)
                      (autogc--error "*** Error: inheritance cycle detected")
                      )

(setcdr (last (assoc superclass answer-list)) (cons (car ptr-3) nil))
                    ;;
                    ;; NOTE: I found a better why to debug infinite loops (above)
                    ;;
                    ;;(if (> (incf count) 100)
                    ;;   (error "Inheritance heirarchy has an infinite loop"))

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

(defun autogc-inheritance--do-all (file-list)
  (let (sup-list-1 sup-list-2 subs-list)
    (setq sup-list-1  (autogc-inheritance--get-class-superclasses file-list))
    (setq sub-list-2  (autogc-inheritance--get-subclasses sup-list-1))
    (setq subs-list   (autogc-inheritance--get-all-subclasses sub-list-2))
    subs-list))

(provide 'autogc-inheritance)