artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mes: Resurrect backtraces.

Browse source 
* mes/module/mes/catch.mes (%eh): Resurrect backtraces.
(display-frame): New function.
(display-backtrace): Use it.
This commit is contained in:
Jan (janneke) Nieuwenhuizen 2019-11-10 16:08:13 +01:00
parent 96e6ecaf7d
commit 6561480506
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
1 changed files with 33 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

50
mes/module/mes/catch.mes
View file

@ -1,7 +1,7 @@
;;; -*-scheme-*- ;;; -*-scheme-*-
;;; GNU Mes --- Maxwell Equations of Software ;;; GNU Mes --- Maxwell Equations of Software
;;; Copyright © 2016,2018 Jan (janneke) Nieuwenhuizen <janneke@gnu.org> ;;; Copyright © 2016,2018,2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; ;;;
;;; This file is part of GNU Mes. ;;; This file is part of GNU Mes.
;;; ;;;
@ -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)))