cgit.sxemacs.org Git - packages/blob - xemacs-packages/semantic/semantic-adebug-eieio.el

   1 ;;; semantic-adebug-eieio.el --- EIEIO extensions to adebug
   2
   3 ;; Copyright (C) 2007 Eric M. Ludlam
   4
   5 ;; Author: Eric M. Ludlam <eric@siege-engine.com>
   6 ;; X-RCS: $Id: semantic-adebug-eieio.el,v 1.1 2007-11-26 15:10:31 michaels Exp $
   7
   8 ;; This program is free software; you can redistribute it and/or
   9 ;; modify it under the terms of the GNU General Public License as
  10 ;; published by the Free Software Foundation; either version 2, or (at
  11 ;; your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be useful, but
  14 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  15 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 ;; General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public License
  19 ;; along with this program; see the file COPYING.  If not, write to
  20 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  21 ;; Boston, MA 02110-1301, USA.
  22
  23 ;;; Commentary:
  24 ;;
  25 ;; Extensions to semantic Adebug for EIEIO objects.
  26 ;;
  27
  28 ;;;###autoload
  29 (defun semantic-adebug-insert-object-fields (object prefix)
  30   "Insert all the fields of OBJECT.
  31 PREFIX specifies what to insert at the start of each line."
  32   (let ((attrprefix (concat (make-string (length prefix) ? ) "] "))
  33         )
  34     (semantic-adebug/eieio-insert-fields object attrprefix)
  35     )
  36   )
  37
  38 (defun semantic-adebug-insert-object-fields-from-point (point)
  39   "Insert the object fields found at the object button at POINT."
  40   (let ((object (get-text-property point 'adebug))
  41         (indent (get-text-property point 'adebug-indent))
  42         start end
  43         )
  44     (end-of-line)
  45     (setq start (point))
  46     (forward-char 1)
  47     (semantic-adebug-insert-object-fields object
  48                                           (concat (make-string indent ? )
  49                                                   "~ "))
  50     (setq end (point))
  51     (goto-char start)
  52     ))
  53
  54 ;;;###autoload
  55 (defun semantic-adebug-insert-object-button (object prefix prebuttontext)
  56   "Insert a button representing OBJECT.
  57 PREFIX is the text that preceeds the button.
  58 PREBUTTONTEXT is some text between PREFIX and the object button."
  59   (let ((start (point))
  60         (end nil)
  61         (str (object-name object))
  62         (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots"
  63                      (object-name-string object)
  64                      (object-class object)
  65                      (class-parents (object-class object))
  66                      (length (object-slots object))
  67                      ))
  68         )
  69     (insert prefix prebuttontext str)
  70     (setq end (point))
  71     (put-text-property (- end (length str)) end 'face 'font-lock-keyword-face)
  72     (put-text-property start end 'adebug object)
  73     (put-text-property start end 'adebug-indent(length prefix))
  74     (put-text-property start end 'adebug-prefix prefix)
  75     (put-text-property start end 'help-echo tip)
  76     (put-text-property start end 'adebug-function
  77                        'semantic-adebug-insert-object-fields-from-point)
  78     (insert "\n")
  79     )
  80   )
  81
  82 ;;; METHODS
  83 ;;
  84 ;; Each object should have an opportunity to show stuff about itself.
  85
  86 (defmethod semantic-adebug/eieio-insert-fields ((obj eieio-default-superclass)
  87                                                 prefix)
  88   "Insert the fields of OBJ into the current ADEBUG buffer."
  89   (semantic-adebug-insert-thing (object-name-string obj)
  90                                 prefix
  91                                 "Name: ")
  92   (let* ((cl (object-class obj))
  93          (cv (class-v cl)))
  94     (semantic-adebug-insert-thing (class-constructor cl)
  95                                   prefix
  96                                   "Class: ")
  97     ;; Loop over all the public slots
  98     (let ((publa (aref cv class-public-a))
  99           (publd (aref cv class-public-d))
 100           )
 101       (while publa
 102         (if (slot-boundp obj (car publa))
 103             (let ((i (class-slot-initarg cl (car publa)))
 104                   (v (eieio-oref obj (car publa))))
 105               (semantic-adebug-insert-thing
 106                v prefix (concat
 107                          (if i (symbol-name i)
 108                            (symbol-name (car publa)))
 109                          " ")))
 110           ;; Unbound case
 111           (let ((i (class-slot-initarg cl (car publa))))
 112             (semantic-adebug-insert-thing
 113              "#unbound" prefix
 114              (concat (if i (symbol-name i)
 115                        (symbol-name (car publa)))
 116                      " ")))
 117           )
 118         (setq publa (cdr publa) publd (cdr publd)))
 119       )))
 120
 121 ;;; Code:
 122
 123 (provide 'semantic-adebug-eieio)
 124
 125 ;;; semantic-adebug-eieio.el ends here