diff options
| -rw-r--r-- | geiser/evaluation.scm | 84 |
1 files changed, 21 insertions, 63 deletions
diff --git a/geiser/evaluation.scm b/geiser/evaluation.scm index 37f4171..537e145 100644 --- a/geiser/evaluation.scm +++ b/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}." |