diff options
| -rw-r--r-- | elisp/geiser-connection.el | 3 | ||||
| -rw-r--r-- | elisp/geiser-debug.el | 16 | ||||
| -rw-r--r-- | elisp/geiser-guile.el | 3 | ||||
| -rw-r--r-- | elisp/geiser-syntax.el | 38 | ||||
| -rw-r--r-- | scheme/guile/geiser/evaluation.scm | 84 |
5 files changed, 54 insertions, 90 deletions
diff --git a/elisp/geiser-connection.el b/elisp/geiser-connection.el index 702f3b6..33579f6 100644 --- a/elisp/geiser-connection.el +++ b/elisp/geiser-connection.el @@ -204,7 +204,8 @@ (geiser-con--connection-clean-current-request geiser-con--connection))))) (defadvice comint-redirect-setup - (after geiser-con--advice (output-buffer comint-buffer finished-regexp &optional echo)) + (after geiser-con--advice + (output-buffer comint-buffer finished-regexp &optional echo)) (with-current-buffer comint-buffer (when geiser-con--connection (setq mode-line-process nil)))) (ad-activate 'comint-redirect-setup) diff --git a/elisp/geiser-debug.el b/elisp/geiser-debug.el index bc155c9..7ebd0b5 100644 --- a/elisp/geiser-debug.el +++ b/elisp/geiser-debug.el @@ -72,14 +72,9 @@ (defsubst geiser-debug--frame-source-column (src) (or (caddr src) 0)) (defun geiser-debug--display-stack (stack) - (let* ((frames (cdr stack)) - (step 2) - (indent (* (length frames) step))) - (dolist (f frames) - (geiser-debug--display-stack-frame f indent) - (setq indent (- indent step))))) - -(defun geiser-debug--display-stack-frame (frame offset) + (mapc 'geiser-debug--display-stack-frame (reverse (cdr stack)))) + +(defun geiser-debug--display-stack-frame (frame) (let ((procedure (geiser-debug--frame-proc frame)) (source (geiser-debug--frame-source frame)) (description (geiser-debug--frame-desc frame))) @@ -89,7 +84,7 @@ (geiser-debug--frame-source-line source) (1+ (geiser-debug--frame-source-column source)))) (insert "In expression:\n")) - (insert (format "%s%s\n" (make-string offset ?\ ) description)))) + (insert (format "%s\n" description)))) (defsubst geiser-debug--wrap-region (str) (format "(begin %s)" str)) @@ -112,7 +107,8 @@ (defun geiser-debug--expand-region (start end all wrap) (let* ((str (buffer-substring-no-properties start end)) (wrapped (if wrap (geiser-debug--wrap-region str) str)) - (code `(:eval ((:ge macroexpand) (quote (:scm ,wrapped)) ,(if all :t :f)))) + (code `(:eval ((:ge macroexpand) (quote (:scm ,wrapped)) + ,(if all :t :f)))) (ret (geiser-eval--send/wait code)) (err (geiser-eval--retort-error ret)) (result (geiser-eval--retort-result ret))) diff --git a/elisp/geiser-guile.el b/elisp/geiser-guile.el index c6c165b..44a4e9f 100644 --- a/elisp/geiser-guile.el +++ b/elisp/geiser-guile.el @@ -110,7 +110,8 @@ This function uses `geiser-guile-init-file' if it exists." (geiser-guile-get-module (match-string-no-properties 1)) :f))) ((listp module) module) - ((stringp module) (or (ignore-errors (car (read-from-string module))) :f)) + ((stringp module) + (or (ignore-errors (car (read-from-string module))) :f)) (t :f))) (defun geiser-guile-symbol-begin (module) diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el index 472a4e5..14d996c 100644 --- a/elisp/geiser-syntax.el +++ b/elisp/geiser-syntax.el @@ -85,20 +85,27 @@ (geiser-popup--define syntax " *geiser syntax analyst*" scheme-mode) (defun geiser-syntax--prepare-scheme-for-elisp-reader () - (goto-char (point-min)) - (while (re-search-forward "#\<\\([^>]*?\\)\>" nil t) - (let ((from (match-beginning 1)) - (to (match-end 1))) - (goto-char from) - (while (re-search-forward "\\([() ;'`]\\)" to t) - (replace-match "\\\\\\1")) - (goto-char to))) - (goto-char (point-min)) - (while (re-search-forward "#(" nil t) (replace-match "(vector ")) - (goto-char (point-min)) - (while (re-search-forward "#" nil t) (replace-match "\\\\#")) - (goto-char (point-min)) - (skip-syntax-forward "^(")) + (let ((end (save-excursion + (goto-char (point-max)) + (and (re-search-backward "(output \\. \"" nil t) + (point))))) + (goto-char (point-min)) + (while (re-search-forward "#\<\\([^>]*?\\)\>" end t) + (let ((from (match-beginning 1)) + (to (match-end 1))) + (goto-char from) + (while (re-search-forward "\\([ ;'`]\\)" to t) + (replace-match "\\\\\\1")) + (goto-char from) + (while (re-search-forward "[()]" to t) + (replace-match "")) + (goto-char to))) + (goto-char (point-min)) + (while (re-search-forward "#(" end t) (replace-match "(vector ")) + (goto-char (point-min)) + (while (re-search-forward "#" end t) (replace-match "\\\\#")) + (goto-char (point-min)) + (skip-syntax-forward "^("))) (defsubst geiser-syntax--del-sexp (arg) (let ((p (point))) @@ -121,7 +128,8 @@ (when p ;; inside a comment or string (delete-region p (point-max)) (insert geiser-syntax--placeholder))) - (when (cond ((eq (char-after (1- (point))) ?\)) (geiser-syntax--del-sexp -1) t) + (when (cond ((eq (char-after (1- (point))) ?\)) + (geiser-syntax--del-sexp -1) t) ((geiser-syntax--beginning-of-form) (delete-region (point) (point-max)) t) ((memq (char-after (1- (point))) (list ?. ?@ ?, ?\' ?\` ?\# ?\\)) diff --git a/scheme/guile/geiser/evaluation.scm b/scheme/guile/geiser/evaluation.scm index 37f4171..537e145 100644 --- a/scheme/guile/geiser/evaluation.scm +++ b/scheme/guile/geiser/evaluation.scm @@ -32,64 +32,20 @@ ge:load-file) #:use-module (srfi srfi-1) #:use-module (system base compile) + #:use-module (system base pmatch) #:use-module (system vm program) - #:use-module (ice-9 debugger utils) #:use-module (ice-9 pretty-print)) -(define (make-result result output) - (list (cons 'result result) (cons 'output output))) - -(define (make-error key args stack) - (list (cons 'error (apply parse-error (cons key args))) - (cons 'stack (parse-stack stack)))) - -(define (parse-stack stack) - (if stack - (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))) - (msg (and (> len 1) (second args))) - (margs (and (> len 2) (third args))) - (rest (and (> len 3) (fourth args)))) - (list (cons 'key key) - (cons 'subr (or subr '())) - (cons 'msg (if msg (apply format (cons #f (cons msg margs))) '())) - (cons 'rest (or rest '()))))) +(define (handle-error stack . args) + (pmatch args + ((,key ,subr ,msg ,args . ,rest) + (display "Backtrace:\n") + (if (stack? stack) + (display-backtrace stack (current-output-port))) + (newline) + (display-error stack (current-output-port) subr msg args rest)) + (else (display (format "ERROR: ~a, args: ~a" (car args) (cdr args))))) + `(error (key . ,(car args)))) (define (evaluate form module-name evaluator) (let ((module (or (and (list? module-name) @@ -106,12 +62,14 @@ (set! result (catch #t (lambda () - (start-stack 'id (evaluator form module))) - (lambda (key . args) - (set! error (make-error key args captured-stack))) - (lambda (key . args) - (set! captured-stack (make-stack #t 2 2))))))))) - (write (or error (make-result result output))) + (start-stack 'geiser-eval (evaluator form module))) + (lambda args + (set! error #t) + (apply handle-error captured-stack args)) + (lambda args + (set! captured-stack (make-stack #t 1 13))))))))) + (write `(,(if error result (cons 'result result)) + (output . ,output))) (newline)))) (define (eval-compile form module) @@ -130,8 +88,8 @@ "Compile and load file, given its full @var{path}." (evaluate `(and (compile-file ,path) (load-compiled ,(compiled-file-name path))) - #f - eval)) + '(system base compile) + eval-compile)) (define (ge:load-file path) "Load file, given its full @var{path}." |