aliens/tekuti
1
0
Fork 0
Code Activity

(tekuti util) fixen

Browse source 
* tekuti/util.scm (unwind-protect): Move definition up.
  (with-backtrace*): Update to backtrace in the throw handler.
This commit is contained in:
Andy Wingo 2010-10-14 13:12:08 +02:00
parent 69f7a83449
commit 29f45c45bb
1 changed files with 19 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

51
tekuti/util.scm
View file

@ -58,6 +58,13 @@
(apply kons knil (list-head values n)) (apply kons knil (list-head values n))
(list-tail values n)))) (list-tail values n))))
(define-syntax unwind-protect
(syntax-rules ()
((_ form cleanup0 cleanups ...)
(dynamic-wind (lambda () #t)
(lambda () form)
(lambda () cleanup0 cleanups ...)))))
(define (call-with-temp-file contents proc) (define (call-with-temp-file contents proc)
(let* ((template (string-copy "/tmp/tekutiXXXXXX")) (let* ((template (string-copy "/tmp/tekutiXXXXXX"))
(tmp (mkstemp! template))) (tmp (mkstemp! template)))
@ -101,13 +108,6 @@
(define (dbg fmt . args) (define (dbg fmt . args)
(apply format (current-error-port) fmt args)) (apply format (current-error-port) fmt args))
(define-syntax unwind-protect
(syntax-rules ()
((_ form cleanup0 cleanups ...)
(dynamic-wind (lambda () #t)
(lambda () form)
(lambda () cleanup0 cleanups ...)))))
(define (dsu-sort list key less) (define (dsu-sort list key less)
(map cdr (map cdr
(stable-sort (map (lambda (x) (cons (key x) x)) list) (stable-sort (map (lambda (x) (cons (key x) x)) list)
@ -158,32 +158,19 @@
(if (null? l) (reverse dest) (if (null? l) (reverse dest)
(loop (cdr l) (cons (car l) (cons elem dest))))))) (loop (cdr l) (cons (car l) (cons elem dest)))))))
(define (handle-error key . args)
(let ((cep (current-error-port))
(highlights (if (or (eq? key 'wrong-type-arg)
(eq? key 'out-of-range))
(list-ref args 3)
'())))
(newline cep)
(display "Backtrace:\n")
(display-backtrace (fluid-ref the-last-stack) cep
#f #f highlights)
(newline cep)
(if (= (length args) 4)
(apply display-error (fluid-ref the-last-stack) cep args)
(format cep "~a" args))
(force-output cep)
(apply throw key args)))
(define (with-backtrace* proc) (define (with-backtrace* proc)
(debug-enable 'backtrace) (let ((cep (current-error-port)))
(start-stack 'with-backtrace (start-stack
(catch #t 'with-backtrace
proc (with-throw-handler
handle-error #t
(lambda args proc
(fluid-set! the-last-stack (make-stack #t 2 0)) (lambda (k . args)
(apply throw args))))) (newline cep)
(format cep "Throw to `~a', args: ~s\n" k args)
(display "Backtrace:\n" cep)
(display-backtrace (make-stack #t) cep)
(newline cep))))))
(define-syntax with-backtrace (define-syntax with-backtrace
(syntax-rules () (syntax-rules ()