diff options
| -rw-r--r-- | elisp/geiser-autodoc.el | 57 | ||||
| -rw-r--r-- | elisp/geiser-compile.el | 34 | ||||
| -rw-r--r-- | elisp/geiser-debug.el | 96 | ||||
| -rw-r--r-- | elisp/geiser-eval.el | 1 | ||||
| -rw-r--r-- | elisp/geiser-mode.el | 17 | ||||
| -rw-r--r-- | scheme/guile/geiser/emacs.scm | 40 | ||||
| -rw-r--r-- | scheme/guile/geiser/introspection.scm | 15 |
7 files changed, 175 insertions, 85 deletions
diff --git a/elisp/geiser-autodoc.el b/elisp/geiser-autodoc.el index 3c23b32..7460aa1 100644 --- a/elisp/geiser-autodoc.el +++ b/elisp/geiser-autodoc.el @@ -75,8 +75,7 @@ when `geiser-autodoc-display-module-p' is on." (cdr pr)) (setq geiser-autodoc--last-funs funs) (geiser-eval--send - `(:eval ((:ge arguments) - ,@(mapcar (lambda (f) (list 'quote (car f))) funs))) + `(:eval ((:ge arguments) ,@(mapcar (lambda (f) (list 'quote (car f))) funs))) 'geiser-autodoc--function-args-cont) "")))) @@ -84,12 +83,9 @@ when `geiser-autodoc-display-module-p' is on." (let ((result (geiser-eval--retort-result ret))) (when (and result (listp result)) (setq geiser-autodoc--last result) - (eldoc-message - (geiser-autodoc--fun-args-str (car result) - (cdr result) - (or (cdr (assoc (car result) - geiser-autodoc--last-funs)) - 0)))))) + (let* ((pos (or (cdr (assoc (car result) geiser-autodoc--last-funs)) 0)) + (msg (geiser-autodoc--fun-args-str (car result) (cdr result) pos))) + (when msg (eldoc-message msg)))))) (defun geiser-autodoc--insert (sym current pos) (let ((str (format "%s" sym))) @@ -100,34 +96,35 @@ when `geiser-autodoc-display-module-p' is on." (insert str))) (defun geiser-autodoc--fun-args-str (fun args pos) - (save-current-buffer - (set-buffer (geiser-syntax--font-lock-buffer)) - (erase-buffer) - (let* ((current 0) - (module (and geiser-autodoc-display-module-p - (cdr (assoc 'module args)))) - (fun (if module - (format geiser-autodoc-procedure-name-format module fun) - fun))) - (insert "(") - (geiser-autodoc--insert fun current pos) - (dolist (arg (cdr (assoc 'required args))) + (when fun + (save-current-buffer + (set-buffer (geiser-syntax--font-lock-buffer)) + (erase-buffer) + (let* ((current 0) + (module (and geiser-autodoc-display-module-p + (cdr (assoc 'module args)))) + (fun (if module + (format geiser-autodoc-procedure-name-format module fun) + fun))) + (insert "(") + (geiser-autodoc--insert fun current pos) + (dolist (arg (cdr (assoc 'required args))) + (setq current (1+ current)) + (insert " ") + (geiser-autodoc--insert arg current pos)) (setq current (1+ current)) - (insert " ") - (geiser-autodoc--insert arg current pos)) - (setq current (1+ current)) - (when (cdr (assoc 'optional args)) - (when (> pos current) (setq current pos)) - (insert " . ") - (geiser-autodoc--insert (cdr (assoc 'optional args)) current pos)) - (insert ")") - (buffer-string)))) + (when (cdr (assoc 'optional args)) + (when (> pos current) (setq current pos)) + (insert " . ") + (geiser-autodoc--insert (cdr (assoc 'optional args)) current pos)) + (insert ")") + (buffer-string))))) ;;; Autodoc function: (defun geiser-autodoc--eldoc-function () - (geiser-autodoc--function-args (geiser-syntax--enclosing-form-data))) + (or (geiser-autodoc--function-args (geiser-syntax--enclosing-form-data)) "")) ;;; Autodoc mode: diff --git a/elisp/geiser-compile.el b/elisp/geiser-compile.el index 82200a5..8b4a4db 100644 --- a/elisp/geiser-compile.el +++ b/elisp/geiser-compile.el @@ -24,20 +24,11 @@ ;;; Code: +(require 'geiser-debug) (require 'geiser-eval) -(require 'geiser-popup) (require 'geiser-base) -;;; Compilation buffer: - -(define-derived-mode geiser-compile-mode compilation-mode "Geiser Compilation" - "Major mode showing the results of compiling or loading scheme files. -\{geiser-compile-mode-keymap}") - -(geiser-popup--define compile "*Geiser compilation*" geiser-compile-mode) - - ;;; Auxiliary functions: (defun geiser-compile--buffer/path (&optional path) @@ -49,25 +40,10 @@ (cons buffer path)))) (defun geiser-compile--display-result (title ret) - (let ((err (geiser-eval--retort-error ret)) - (output (geiser-eval--retort-output ret))) - (geiser-compile--with-buffer - (erase-buffer) - (insert title) - (newline) - (when output - (insert output) - (newline)) - (when err - (insert "\n" (geiser-eval--error-msg err) "\n")) - (goto-char (point-min))) - (if (not err) - (message "%s %s" title (if (> 0 (length output)) - (geiser--chomp output) - (or (geiser-eval--retort-result ret) - "OK!"))) - (message "") - (geiser-compile--pop-to-buffer)))) + (if (not (geiser-eval--retort-error ret)) + (message "%s %s" title (or (geiser-eval--retort-result ret) "OK!")) + (message "") + (geiser-debug--display-retort title ret))) (defun geiser-compile--file-op (path compile-p msg) (let* ((b/p (geiser-compile--buffer/path path)) diff --git a/elisp/geiser-debug.el b/elisp/geiser-debug.el new file mode 100644 index 0000000..c32c895 --- /dev/null +++ b/elisp/geiser-debug.el @@ -0,0 +1,96 @@ +;; geiser-debug.el -- displaying debug information + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; Start date: Mon Feb 23, 2009 22:34 + +;; This file 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 file 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 this program. If not, see <http://www.gnu.org/licenses/>. + +;;; Comentary: + +;; Buffer and associated mode for displaying results of evaluations +;; and compilations. + +;;; Code: + +(require 'geiser-eval) +(require 'geiser-popup) +(require 'geiser-base) + + +;;; Debug buffer mode: + +(defvar geiser-debug-mode-map + (let ((map (make-keymap))) + (suppress-keymap map) + (define-key map "g" 'geiser-debug-goto-error) + (define-key map "\C-c\C-c" 'geiser-debug-goto-error) + (define-key map "n" 'next-line) + (define-key map "p" 'previous-line) + map)) + +(define-derived-mode geiser-debug-mode compilation-mode "Geiser Dbg" + "A major mode for displaying Scheme compilation and evaluation results. +\\{geiser-debug-mode-map}") + + +;;; Buffer for displaying evaluation results: + +(geiser-popup--define debug "*Geiser dbg*" geiser-debug-mode) + + +;;; Displaying retorts + +(defun geiser-debug--display-retort (what ret) + (let* ((err (geiser-eval--retort-error ret)) + (output (geiser-eval--retort-output ret)) + (stack (geiser-eval--retort-stack ret)) + (step 2) + (indent step)) + (when err + (geiser-debug--with-buffer + (erase-buffer) + (insert what) + (newline 2) + (insert (geiser-eval--error-str err) "\n\n") + (when output (insert output "\n\n")) + (dolist (f (reverse (cdr stack))) + (geiser-debug--display-stack-frame f indent) + (setq indent (+ step indent))) + (goto-char (point-min))) + (geiser-debug--pop-to-buffer)))) + +(defsubst geiser-debug--frame-proc (frame) (cdr (assoc 'procedure frame))) +(defsubst geiser-debug--frame-desc (frame) (cdr (assoc 'description frame))) +(defsubst geiser-debug--frame-source (frame) (cdr (assoc 'source frame))) +(defsubst geiser-debug--frame-source-file (src) (car src)) +(defsubst geiser-debug--frame-source-line (src) (or (cadr src) 1)) +(defsubst geiser-debug--frame-source-column (src) (or (caddr src) 0)) + +(defun geiser-debug--display-stack-frame (frame offset) + (let ((procedure (geiser-debug--frame-proc frame)) + (source (geiser-debug--frame-source frame)) + (description (geiser-debug--frame-desc frame))) + (if source + (insert (format "%s:%s:%s\n" + (geiser-debug--frame-source-file source) + (geiser-debug--frame-source-line source) + (geiser-debug--frame-source-column source))) + (insert "In expression:\n")) + (insert (format "%s%s\n" (make-string offset ?\ ) description)))) + + +(provide 'geiser-debug) +;;; geiser-debug.el ends here diff --git a/elisp/geiser-eval.el b/elisp/geiser-eval.el index 785f441..09f12da 100644 --- a/elisp/geiser-eval.el +++ b/elisp/geiser-eval.el @@ -125,6 +125,7 @@ (defsubst geiser-eval--retort-result (ret) (cdr (assoc 'result ret))) (defsubst geiser-eval--retort-output (ret) (cdr (assoc 'output ret))) (defsubst geiser-eval--retort-error (ret) (cdr (assoc 'error ret))) +(defsubst geiser-eval--retort-stack (ret) (cdr (assoc 'stack ret))) (defsubst geiser-eval--error-key (err) (cdr (assoc 'key err))) (defsubst geiser-eval--error-subr (err) (cdr (assoc 'subr err))) diff --git a/elisp/geiser-mode.el b/elisp/geiser-mode.el index 3c2f1a9..e308c07 100644 --- a/elisp/geiser-mode.el +++ b/elisp/geiser-mode.el @@ -30,8 +30,8 @@ (require 'geiser-completion) (require 'geiser-edit) (require 'geiser-autodoc) +(require 'geiser-debug) (require 'geiser-eval) -(require 'geiser-popup) (require 'geiser-custom) (require 'geiser-base) @@ -57,19 +57,6 @@ ;;; Auxiliary functions: -(geiser-popup--define mode "*Geiser evaluation results*" scheme-mode) - -(defun geiser-eval--display-error (err output) - (if (not output) - (message (geiser-eval--error-str err)) - (geiser-mode--with-buffer - (erase-buffer) - (insert ";; " (geiser-eval--error-str err)) - (newline 2) - (insert output) - (newline)) - (geiser-mode--pop-to-buffer))) - (defun geiser-eval--send-region (compile start end and-go) (let* ((str (buffer-substring-no-properties start end)) (code `(,(if compile :comp :eval) (:scm ,str))) @@ -81,7 +68,7 @@ (goto-char (point-max))) (if (not err) (message (format "=> %s" (geiser-eval--retort-result ret))) - (geiser-eval--display-error err (geiser-eval--retort-output ret))))) + (geiser-debug--display-retort str ret)))) ;;; Evaluation commands: diff --git a/scheme/guile/geiser/emacs.scm b/scheme/guile/geiser/emacs.scm index b9e2d67..90e03dd 100644 --- a/scheme/guile/geiser/emacs.scm +++ b/scheme/guile/geiser/emacs.scm @@ -38,6 +38,8 @@ ge:module-location) #:use-module (srfi srfi-1) #:use-module (system base compile) + #:use-module (system vm program) + #:use-module (ice-9 debugger utils) #:use-module ((geiser introspection) :renamer (symbol-prefix-proc 'ge:))) (define (make-result result output) @@ -49,11 +51,41 @@ (define (parse-stack stack) (if stack - (list - (with-output-to-string - (lambda () (display-backtrace stack (current-output-port))))) + (map (lambda (n) (parse-frame (stack-ref stack n))) + (iota (stack-length stack))) '())) +(define (parse-frame frame) + (list (cons 'frame (frame-number frame)) + (cons 'procedure (or (and (frame-procedure? frame) + (procedure-name (frame-procedure frame))) + '())) + (cons 'source (or (frame->source-position frame) '())) + (cons 'description (with-output-to-string + (lambda () + (if (frame-procedure? frame) + (write-frame-short/application frame) + (write-frame-short/expression frame))))))) + +(define (frame->source-position frame) + (let ((source (if (frame-procedure? frame) + (or (frame-source frame) + (let ((proc (frame-procedure frame))) + (and proc + (procedure? proc) + (procedure-source proc)))) + (frame-source frame)))) + (and source + (cond ((string? (source-property source 'filename)) + (list (source-property source 'filename) + (+ 1 (source-property source 'line)) + (source-property source 'column))) + ((and (pair? source) (list? (cadr source))) + (list (caadr source) + (+ 1 (caddr source)) + (cdddr source))) + (else #f))))) + (define (parse-error key . args) (let* ((len (length args)) (subr (and (> len 0) (first args))) @@ -119,6 +151,6 @@ SUBR, MSG and REST." (define (ge:load-file path) "Load file, given its full @var{path}." - (evaluate `(compile-and-load ,path) '(geiser emacs) eval)) + (evaluate `(load ,path) '(geiser emacs) eval)) ;;; emacs.scm ends here diff --git a/scheme/guile/geiser/introspection.scm b/scheme/guile/geiser/introspection.scm index 29d059b..ca6afae 100644 --- a/scheme/guile/geiser/introspection.scm +++ b/scheme/guile/geiser/introspection.scm @@ -64,13 +64,14 @@ (else #f))) (define (symbol-module sym) - (call/cc - (lambda (k) - (apropos-fold (lambda (module name var init) - (if (eq? name sym) (k (module-name module)) init)) - #f - (symbol->string sym) - (apropos-fold-accessible (current-module)))))) + (and sym + (call/cc + (lambda (k) + (apropos-fold (lambda (module name var init) + (if (eq? name sym) (k (module-name module)) init)) + #f + (symbol->string sym) + (apropos-fold-accessible (current-module))))))) (define (program-args program) (let* ((arity (program-arity program)) |