autogc-cycler.el

    

;;; autogc-cycler.el

;; Copyright (C) 2014-2015 Davin Pearson

;; Emacs Lisp Archive Entry
;; Filename: autogc-cycler.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-cycler--skip-literal (word)
  (let ((i   0)
        (len (length word)))
  (while (< i len)
    (assert (= (char-after (point)) (aref word i)))
    (forward-char 1)
    (incf i))))

(defun autogc-cycler--gulp-identifier ()
  (buffer-substring-no-properties
   (point)
   (progn
     (skip-chars-forward "a-zA-Z_")
     (skip-chars-forward "a-zA-Z0-9_")
     (point))))

;;; (autogc-cycler--fold-type "Array<Foo>")
;;; (autogc-cycler--fold-type "Array<Array<Foo> >")
;;; (autogc-cycler--fold-type "Array<Array<Array<Foo> > >")
;;; (autogc-cycler--fold-type "Array<Array<Array<Array<Foo> > > >")
(defun autogc-cycler--fold-type (type)
  (setq type (cond

((string-match "\\(.*\\)> > > >$" type)
               (concat (substring type (match-beginning 1) (match-end 1)) ">>>>"))
              ((string-match "\\(.*\\)> > >$" type)
               (concat (substring type (match-beginning 1) (match-end 1)) ">>>"))
              ((string-match "\\(.*\\)> >$" type)
               (concat (substring type (match-beginning 1) (match-end 1)) ">>"))
              (t
               type))))

(progn
  (setq autogc-cycler--1 "^   ")
  (setq autogc-cycler--2 "[ \t]+[a-zA-Z_][a-zA-Z0-9_]*;")

(setq autogc-cycler--ptr-foo
        "ptr<[a-zA-Z_][a-zA-Z0-9_]*>")
  (setq autogc-cycler--ptr-array-foo
        "ptr<Array<[a-zA-Z_][a-zA-Z0-9_]*> >" )
  (setq autogc-cycler--ptr-array-array-foo
        "ptr<Array<Array<[a-zA-Z_][a-zA-Z0-9_]*> > >" )
  (setq autogc-cycler--ptr-array-array-array-foo
        "ptr<Array<Array<Array<[a-zA-Z_][a-zA-Z0-9_]*> > > >")
  (setq autogc-cycler--ptr-array-array-array-array-foo
        "ptr<Array<Array<Array<Array<[a-zA-Z_][a-zA-Z0-9_]*> > > > >")
  )

;; (autogc-cycler--get-property)  ptr<A> a;
(defun autogc-cycler--get-property-pair ()
  "Returns a cons pair of property (type . name)"
  (save-excursion
    (let (type-p1 type-p2 type name-p1 name-p2 name)
      (skip-chars-forward " ")

(cond
       ((looking-at autogc-cycler--ptr-foo)
        (autogc-cycler--skip-literal "ptr<")
        (setq type-p1 (point))
        (autogc-cycler--gulp-identifier)
        (setq type-p2 (point)))

((looking-at autogc-cycler--ptr-array-foo)
        (autogc-cycler--skip-literal "ptr<")
        (setq type-p1 (point))
        (skip-chars-forward "Array<")
        (autogc-cycler--gulp-identifier)
        (autogc-cycler--skip-literal ">")
        (setq type-p2 (point))
        (autogc-cycler--skip-literal " "))

((looking-at autogc-cycler--ptr-array-array-foo)
       (autogc-cycler--skip-literal "ptr<")
       (setq type-p1 (point))
       (skip-chars-forward "Array<Array<")
       (autogc-cycler--gulp-identifier)
       (autogc-cycler--skip-literal "> >")
       (setq type-p2 (point))
       (autogc-cycler--skip-literal " "))

((looking-at autogc-cycler--ptr-array-array-array-foo)
       (autogc-cycler--skip-literal "ptr<")
       (setq type-p1 (point))
       (skip-chars-forward "Array<Array<Array<")
       (autogc-cycler--gulp-identifier)
       (autogc-cycler--skip-literal "> > >")
       (setq type-p2 (point))
       (autogc-cycler--skip-literal " "))

((looking-at autogc-cycler--ptr-array-array-array-array-foo)
       (autogc-cycler--skip-literal "ptr<")
       (setq type-p1 (point))
       (skip-chars-forward "Array<Array<Array<Array<")
       (autogc-cycler--gulp-identifier)
       (autogc-cycler--skip-literal "> > > >")
       (setq type-p2 (point))
       (autogc-cycler--skip-literal " "))

(t
       (error "No such case"))
      )

(setq type (autogc-cycler--fold-type (buffer-substring-no-properties type-p1 type-p2)))

(skip-chars-forward ">")
      (skip-chars-forward " \t")

(setq name-p1 (point))
      (skip-chars-forward "a-zA-Z_")
      (skip-chars-forward "a-zA-Z0-9_")

(setq name-p2 (point))

(setq name (buffer-substring-no-properties name-p1 name-p2))

(cons type name)
      )))

(defun autogc-cycler--get-property-list (p1 p2)
  (let (list prop p)
    (save-excursion
      (goto-char p1)
      (while (setq p (or (save-excursion
                           (re-search-forward (concat autogc-cycler--1
                                                      autogc-cycler--ptr-foo
                                                      autogc-cycler--2) p2 t))
                         (save-excursion
                           (re-search-forward (concat autogc-cycler--1
                                                      autogc-cycler--ptr-array-foo
                                                      autogc-cycler--2) p2 t))
                         (save-excursion
                           (re-search-forward (concat autogc-cycler--1
                                                      autogc-cycler--ptr-array-array-foo
                                                      autogc-cycler--2) p2 t))
                         (save-excursion
                           (re-search-forward (concat autogc-cycler--1
                                                      autogc-cycler--ptr-array-array-array-foo
                                                      autogc-cycler--2) p2 t))
                         (save-excursion
                           (re-search-forward (concat autogc-cycler--1
                                                      autogc-cycler--ptr-array-array-array-array-foo
                                                      autogc-cycler--2) p2 t))))

(goto-char p)
        (setq prop (car (save-excursion
                          (beginning-of-line)
                          (autogc-cycler--get-property-pair))))
        (setq list (cons prop list))))
    (reverse list)))

;;; (setq ans (autogc-cycler--get-class-properties '("d:/home/cycler-test.cc")))
;;; (assoc "A" (autogc-cycler--get-class-properties '("d:/t-cycler/a.cc" "d:/t-cycler/b.cc")))
(defun autogc-cycler--get-class-properties (file-list)
  (let ((ptr           file-list)
        (answer        nil)
        (class-name    nil)
        (property-list nil)
        (p1            nil)
        (p2            nil)
        (were-editing  nil))

(save-window-excursion
      (while ptr

        ;; (setq ptr '("~/_emacs"))
        (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))
          (beginning-of-line)
          (forward-line 1)
          (when (looking-at "^{")
            (setq p1 (point))
            (forward-sexp 1)
            (setq p2 (point))
            (setq property-list (autogc-cycler--get-property-list p1 p2))
            (setq answer (cons (cons class-name property-list) answer))))

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

(setq ptr (cdr ptr)))

      ;;(debug)))

      ;;(let ((ptr-3 answer))
      ;;  (while ptr-3
      ;;    (setcar ptr-3 (delete-duplicates (car ptr-3) :test 'equal))
      ;;    ;;(debug)))))
      ;;    (setq ptr-3 (cdr ptr-3))))
      ;;
      ;; NOTE: sets the order correctly
      (reverse answer))
    )
  )

;;;
;;; (assoc "a" '(("a") ("a" "b")))
;;;
;;; (setq properties (autogc-cycler--get-class-properties '("~/cycler-test.cc")))
;;; (insert (prin1-to-string properties))
;;; (setq ap (autogc-cycler--add-arrays properties))
;;; (insert (prin1-to-string ap))
;;; (autogc-cycler--is-cyclic ap)
;;;
(defun autogc-cycler--add-arrays (properties)

(let* ((ptr-1 properties)
         (new-1 nil)
         (new-p (copy-tree properties)))

    ;;(debug)

    (while ptr-1
      (let ((ptr-2 (car ptr-1)))
        (while ptr-2
          (if (string-match "Array<" (car ptr-2))
              (setq new-1 (cons (car ptr-2) new-1)))
          (setq ptr-2 (cdr ptr-2))))
      (setq ptr-1 (cdr ptr-1)))

    ;;(debug)

    (let ((ptr-3 new-1)
          (new-2 nil)
          (s     nil))

      ;;(debug)

      (while ptr-3
        (cond
         ((string-match "^Array<\\([a-zA-Z_][a-zA-Z_]*\\)>$" (car ptr-3))
          (setq s (substring (car ptr-3) (match-beginning 1) (match-end 1)))
          (setq new-2 (cons (list (car ptr-3) s) new-2)))
         ;;
         ;; Array<Array<Foo>> -> ptr<Array<Foo>> -> Array<Foo>
         ;;
         ((string-match "^Array<Array<\\([a-zA-Z_][a-zA-Z_]*\\)>>$" (car ptr-3))
          (setq s (substring (car ptr-3) (match-beginning 1) (match-end 1)))
          (setq new-2 (cons (list (car ptr-3) (concat "Array<" s ">")) new-2)))

((string-match "^Array<Array<Array<\\([a-zA-Z_][a-zA-Z_]*\\)>>>$" (car ptr-3))
          (setq s (substring (car ptr-3) (match-beginning 1) (match-end 1)))
          (setq new-2 (cons (list (car ptr-3) (concat "Array<Array<" s ">>")) new-2)))

((string-match "^Array<Array<Array<Array<\\([a-zA-Z_][a-zA-Z_]*\\)>>>>$" (car ptr-3))
          (setq s (substring (car ptr-3) (match-beginning 1) (match-end 1)))
          (setq new-2 (cons (list (car ptr-3) (concat "Array<Array<Array<" s ">>>")) new-2))
          ;;(debug)
          )

(t
          nil))

        ;;(debug)
        (setq ptr-3 (cdr ptr-3))
        )

      ;;(debug)

      (let ((ptr-4 new-2))
        (while ptr-4
          (setcdr (last new-p) (cons (car ptr-4) nil))
          (setq ptr-4 (cdr ptr-4))))

      ;;(debug)

      new-p)
    )
  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; TODO: search through properties...................
;;;
;;; interesting how it works without :test 'equal
;;;
;;; (but it takes a little longer...)
;;;
;;; REASON: it gets the same property twice...
;;;
;;;

(defun autogc-cycler--remove-duplicate-properties (prop-list)
  (progn
    (setq prop-list (copy-tree prop-list))
    (let ((ptr prop-list))
      (while ptr
        (setcdr (car ptr) (delete-duplicates (cdar ptr) :test 'equal))
        (setq ptr (cdr ptr)))
      prop-list)))

(defun autogc-cycler--do-all (file-list)
  (let (prop-list prop-list-2 prop-list-3)
    ;;
    ;; DONE: added copy-tree to all of these functions...
;;;
;;; autogc-cycler--get-class-properties only calls autogc-cycler--fold-type
;;;
    (setq prop-list   (autogc-cycler--get-class-properties file-list))
    (setq prop-list-2 (autogc-cycler--add-arrays prop-list))
    (setq prop-list-3 (autogc-cycler--remove-duplicate-properties prop-list-2))
    prop-list-3))

(provide 'autogc-cycler)