andrius
/
mes
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

mes: Resurrect backtraces. 

* mes/module/mes/catch.mes (%eh): Resurrect backtraces.
(display-frame): New function.
(display-backtrace): Use it.
This commit is contained in:
Jan Nieuwenhuizen 2019-11-10 16:08:13 +01:00 committed by Jan (janneke) Nieuwenhuizen
parent fd83f6d05e
commit 5e17a0bcbe
No known key found for this signature in database
GPG Key ID: F3C1A0D9C1D65273
1 changed files with 32 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
mes/module/mes/catch.mes
View File

@ -23,17 +23,14 @@
(define %eh (make-fluid (define %eh (make-fluid
(lambda (key . args) (lambda (key . args)
(if #f ;;(defined? 'simple-format) (core:display-error "unhandled exception: ")
(simple-format (current-error-port) "unhandled exception:~a:~a\n" key args) (core:display-error key)
(begin (core:display-error ": ")
(core:display-error "unhandled exception:") (core:write-error args)
(core:display-error key) (core:display-error "\n")
(core:display-error ":")
(core:write-error args)
(core:display-error "\n")))
(core:display-error "Backtrace:\n") (core:display-error "Backtrace:\n")
(display-backtrace (make-stack) (current-error-port)) (display-backtrace (make-stack) (current-error-port))
(exit 1)))) (abort))))
(define (catch key thunk handler) (define (catch key thunk handler)
(let ((previous-eh (fluid-ref %eh))) (let ((previous-eh (fluid-ref %eh)))
@ -58,14 +55,33 @@
(define with-throw-handler catch) ; FIXME: hack for Nyacc 0.75 (define with-throw-handler catch) ; FIXME: hack for Nyacc 0.75
(define (frame-procedure frame) (define (frame-procedure frame)
(struct-ref frame 3)) (let ((f (struct-ref frame 3)))
(or (builtin? f)
(closure? f))))
(define (display-frame frame port)
(core:display-error " ")
(let ((f (struct-ref frame 3)))
(cond ((builtin? f)
(core:display-error "[b] ")
(core:display-error "(")
(core:display-error (struct-ref f 3))
(for-each (lambda (i) (core:display-error " _")) (iota (struct-ref f 4)))
(core:display-error ")"))
((closure? f)
(core:display-error "[c] ")
(let* ((circ (core:car (core:cdr f)))
(name (core:car (core:car (core:cdr circ))))
(args (core:car (core:cdr (core:cdr f)))))
(core:display-error (cons name args))))
(else
(core:display-error "[u] ")
(core:display-error f))))
(core:display-error "\n"))
(define (display-backtrace stack port . rest) (define (display-backtrace stack port . rest)
(let* ((frames (map (lambda (i) (stack-ref stack i)) (iota (stack-length stack)))) (let* ((frames (map (lambda (i) (stack-ref stack i)) (iota (stack-length stack))))
(call-frames (filter frame-procedure frames)) (call-frames (filter frame-procedure frames))
(display-frames (drop-right call-frames 2))) (trace-frames (reverse call-frames))
(for-each (lambda (f) (display-frames (cdr trace-frames)))
(core:display-error " ") (for-each (lambda (f) (display-frame f port)) display-frames)))
(core:display-error f)
(core:display-error "\n"))
display-frames)))