root/lang/elisp/escm/trunk/escm-debug.el @ 9197

Revision 9197, 5.9 kB (checked in by lieutar, 7 years ago)

lang/elisp/escm/trunk: I added a Makefile.

Line 
1;;; escm-debug.el --- Debugger foe escm.
2
3;; Copyright (C) 2008  Free Software Foundation, Inc.
4
5;; Author: lieutar <lieutar@1dk.jp>
6;; Keywords: lisp
7
8;; This file is free software; you can redistribute it and/or modify
9;; it under the terms of the GNU General Public License as published by
10;; the Free Software Foundation; either version 2, or (at your option)
11;; any later version.
12
13;; This file is distributed in the hope that it will be useful,
14;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16;; GNU General Public License for more details.
17
18;; You should have received a copy of the GNU General Public License
19;; along with GNU Emacs; see the file COPYING.  If not, write to
20;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21;; Boston, MA 02111-1307, USA.
22
23;;; Commentary:
24
25;;
26
27;;; Code:
28
29(require 'escm-base)
30
31(defconst escm-debug-vm   nil)
32(defconst escm-debug::level 0)
33(defconst escm-debug::pos   0)
34
35(defun escm-debug (vm &optional p))
36(defun escm-debug::enter ())
37(defun escm-debug::leave ())
38
39(defconst escm-debug-mode-map
40  (let ((m (make-sparse-keymap)))
41    (define-key m "q" 'top-level)
42    (define-key m "n" 'exit-recursive-edit)
43    (define-key m "e" 'escm-debug::eval)
44    (define-key m "r" 'escm-debug::ref)
45    m))
46
47(defun escm-debug::vm-to-string (vm)
48  (escm-util::stext
49   (format "   val: %s\n"
50           (mapconcat (lambda (v) (escm-object::to-string v))
51                      (escm-vm::get-val-stack vm)
52                      "\n        "))
53   (format "   arg: %s\n" (mapconcat
54                           (lambda (a)
55                             (format "%s" a))
56                           (escm-vm::get-arg-stack vm)
57                           "\n        "))
58   (format "   env: %s\n"
59           (escm-debug::describe-env (escm-vm::current-env vm)
60                                     "        "))
61   (format "    pc: %s\n" (escm-vm::get-pc-stack vm))
62   (format "  proc: septh: %s\n%S\n"
63           (length (escm-vm::get-proc-stack vm))
64           (escm-iproc::get-src (escm-vm::current-src vm)))
65   ))
66;;(escm-vm::eval (escm-vm::new) '(+ 1 2))
67
68(defun escm-debug::describe-env (env &optional indent)
69  (let ((retbuf ()))
70    (while env
71      (when retbuf (setq retbuf (cons "    " (cons (or indent "") (cons "\n" retbuf)))))
72      (setq retbuf (cons (escm-object::to-string env) retbuf))
73      (setq env    (escm-env::get-parent env)))
74  (apply 'concat (reverse retbuf))))
75
76(defun escm-debug::eval (expr)
77  (interactive (read-string "expr: "))
78  (let* ((ic (escm::iproc-nimonic-at (escm-vm::current-src vm)
79                                     (escm-vm::current-pc  vm)
80                                     escm-debug::pos))
81         (args (escm-iblock-content::get-args ic))
82         (i       1)
83         (binding (mapcar
84                   (lambda (v)
85                     (list (intern "$%d" (1- (setq i (1+ i))))
86                           v))
87                   args))
88         (err     nil)
89         (retval  (condition-case *err*
90                      (eval `(let ,binding ,@(read expr)))
91                    (error (setq err *err*)))))
92    (message (escm-util::stext
93              (if err
94                  `(("error: ") ,(format "%S" err))
95                `(("result: ") ,(format "%S" retval)))))))
96
97(defun escm-debug::ref (sym)
98  (interactive (list (intern (read-string "variable: "))))
99  (let ((env (escm-vm::current-env escm-debug-vm)))
100    (condition-case *err*
101        (message (format "%s = %S"
102                         sym
103                         (escm-env::gref env sym)))
104      (escm-void-variable
105       (message "unbond ...")))))
106
107(defun escm-debug-mode ()
108  (interactive)
109  (kill-all-local-variables)
110  (use-local-map escm-debug-mode-map))
111
112(defun escm-debug::init-vm-buffer (vm)
113  (toggle-read-only -1)
114  (delete-region (point-min) (point-max))
115  (insert (escm-debug::vm-to-string vm))
116  (toggle-read-only 1)
117  (goto-char (point-min)))
118
119(defun escm-debug::init-code-buffer (vm pos)
120  (toggle-read-only -1)
121  (delete-region (point-min) (point-max))
122  (let* ((b   0)
123         (pc (escm-vm::current-pc vm))
124         (cur nil)
125         (first t))
126    (mapcar
127     (lambda (cb)
128       (if first
129           (setq first nil)
130         (insert (make-string (1- (window-width)) ?-) "\n"))
131       (let ((i   0))
132         (mapcar
133          (lambda (ic)
134            (insert (escm-util::stext
135                     `(face ,(if (= pc b)
136                                 (if (= i pos)
137                                     (progn
138                                       (setq cur (point))
139                                       'escm-debug::current-line-face)
140                                   'escm-debug::other-line-face)
141                               'escm-debug::other-block-face)
142                            ,(concat ic "\n"))))
143            (progn (setq i (1+ i))))
144          cb))
145       (setq b (1+ b)))
146     (escm-iproc::to-debug-info (escm-vm::current-src vm)))
147    (when cur
148      (goto-char cur)
149      (recenter)))
150  (toggle-read-only 1))
151
152
153
154(defface  escm-debug::other-block-face
155  '((((class color) (background light))
156     (:foreground "green" ))
157    (((class color) (background dark))
158     (:foreground "purple"))
159    (t ()))
160  "")
161
162(defface  escm-debug::other-line-face
163  '((((class color) (background light))
164     (:foreground "blue" ))
165    (((class color) (background dark))
166     (:foreground "yellow"))
167    (t ()))
168  "")
169
170(defface  escm-debug::current-line-face
171  '((((class color) (background light))
172     (:foreground "blue" :background "yellow"))
173    (((class color) (background dark))
174     (:foreground "yellow" :background "blue"))
175    (t ()))
176  "")
177
178
179
180(defadvice escm-debug (around escm-debug first (vm &optional p))
181  (escm-debug::step vm p))
182
183
184(defun escm-debug::step (vm p)
185  (let* ((escm-debug-vm vm)
186         (codebuf (get-buffer-create "*escm-code*"))
187         (vmbuf   (get-buffer-create "*escm-vm*"  ))
188         (codewin)
189         (vmwin))
190    (save-window-excursion
191      (delete-other-frames)
192      (setq codewin (selected-window))
193      (when p
194        (switch-to-buffer codebuf)
195        (escm-debug-mode)
196        (escm-debug::init-code-buffer vm p))
197      (setq vmwin (split-window-horizontally))
198      (shrink-window-horizontally (- (window-width) 20))
199      (select-window vmwin)
200      (switch-to-buffer vmbuf)
201      (escm-debug-mode)
202      (escm-debug::init-vm-buffer vm)
203      (recursive-edit)
204      )
205    (kill-buffer codebuf)
206    (kill-buffer vmbuf)))
207
208(defun escm-debug::activate ()
209  (interactive)
210  (ad-activate   'escm-debug 'escm-debug))
211
212(defun escm-debug::deactivate ()
213  (interactive)
214  (ad-deactivate 'escm-debug))
215
216(provide 'escm-debug)
217;;; escm-debug.el ends here
Note: See TracBrowser for help on using the browser.