better source description in backtraces

parent 4b0225b7
......@@ -6,6 +6,7 @@ moddir=$(prefix)/share/guile/site/$(GUILE_EFFECTIVE_VERSION)
godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache
SOURCES = \
language/python/adress.scm \
language/python/guilemod.scm \
oop/dict.scm \
oop/pf-objects.scm \
......
......@@ -3,10 +3,11 @@
#:use-module (ice-9 control)
#:use-module (oop pf-objects)
#:use-module (oop goops)
#:use-module ((oop dict) #:select (slask-it))
#:use-module ((oop dict) #:select (set-procedure-property!- slask-it))
#:use-module (system syntax internal)
#:use-module (rnrs bytevectors)
#:use-module (language python guilemod)
#:use-module (language python adress)
#:use-module (language python dict)
#:use-module (language python exceptions)
#:use-module (language python yield)
......@@ -48,12 +49,14 @@
(define-inlinable (W x) `(@ (language python with) ,x))
(define (NRR name n m f x)
(set-procedure-property! x 'source
`((filename . ,f) (line . ,n) (column . ,m)))
(set-procedure-property! x 'filename f)
(set-procedure-property! x 'line n)
(set-procedure-property! x 'column m)
(set-procedure-property!- x 'filename f)
(set-procedure-property!- x 'line n)
(set-procedure-property!- x 'column m)
(if name (set-procedure-property! x 'name name))
(set-procedure-property!-- x 'filename f)
(set-procedure-property!-- x 'line n)
(set-procedure-property!-- x 'column m)
(if name (set-procedure-property!-- x 'name name))
x)
(cond-expand
......
......@@ -33,16 +33,22 @@
(values))
((self val . l)
(set self 'value val))))
(define __f
(lambda (self)
(aif it (rawref self 'value #f)
(format #f "~a:~a"
(rawref self '__name__) it)
(format #f "~a"
(rawref self '__name__)))))
(define __str__ __f)
(define __repr__
(lambda (self)
(aif it (ref self '__str__)
(it)
(aif it (rawref self 'value #f)
(format #f "~a:~a"
(rawref self '__name__) it)
(format #f "~a"
(rawref self '__name__)))))))
(__f self)))))
(define-python-class SystemExit ()
(define __init__
......
(define-module (language python guilemod)
#:use-module (system base message)
#:use-module (system foreign)
#:use-module (ice-9 format)
#:use-module (language python adress)
#:use-module ((oop dict) #:select
(procedure-properties- procedure-property-
set-procedure-property!-))
#:export (%add-to-warn-list %dont-warn-list %eval-no-warn))
(define-syntax-rule (defineu f a x)
......@@ -42,6 +47,7 @@
(fluid-ref
%dont-warn-list)))))
(mk-commands (system repl debug) mod-R define-R define-exp-R define-set-R)
(mk-commands (system base compile) mod-C define-C define-exp-C define-set-C)
(mk-commands (system vm program) mod-C2 define-C2 define-exp-C2 define-set-C2)
(mk-commands (system base message) mod-M define-M define-exp-M define-set-M)
......@@ -451,15 +457,18 @@ property alist) using the data in ARGS."
(cond-expand
(guile-3.0
(define (mk-source x)
(catch #t
(lambda ()
(cons* 0
(cdr (assoc 'filename x))
(- (cdr (assoc 'line x)) 1)
(cdr (assoc 'column x))))
(lambda x
#f)))
(define mk-source
(case-lambda
((x n)
(catch #t
(lambda ()
(cons* n
(cdr (assoc 'filename x))
(- (cdr (assoc 'line x)) 1)
(cdr (assoc 'column x))))
(lambda x
#f)))
((x) (mk-source x 0))))
(define (source-for source)
(catch #t
......@@ -470,6 +479,26 @@ property alist) using the data in ARGS."
((C2 source-column) source)))
(lambda x #f)))
(define* (program-source proc ip #:optional
(sources ((C2 program-sources) proc)))
(define (get n) (mk-source (procedure-properties- proc) n))
(let ((x
(let lp ((source #f) (sources sources))
((C2 match) sources
(() source)
(((and s (pc . _)) . sources)
(if (<= pc ip)
(lp s sources)
source))))))
(if x
(aif it (get (car x))
it
x)
(aif it (get 0)
it
x))))
(define* (print-program #:optional program (port (current-output-port))
#:key
(addr ((C2 program-code) program))
......@@ -485,7 +514,7 @@ property alist) using the data in ARGS."
(name (or (and program (procedure-name program))
(and pdi ((C2 program-debug-info-name) pdi))))
(source (or (and program (mk-source
(procedure-property program 'source)))
(procedure-properties- program)))
(source-for
((C2 match) ((C2 find-program-sources) addr)
(() #f)
......@@ -537,7 +566,77 @@ property alist) using the data in ARGS."
(define (write-program prog port)
(print-program prog port))
(define-set-C2 print-program print-program)
(define-set-C2 write-program write-program))
(define-set-C2 print-program print-program)
(define-set-C2 write-program write-program)
(define-set-C2 program-source program-source))
(guile-2.0
(values)))
(define-syntax-rule (R m) (@@ (system repl debug) m))
(cond-expand
(guile-2.2
(define (frame-name frame)
(aif it (procedure-properties-- frame #f)
(aif it (assoc it 'name)
it
#f)
#f))
(define (frame-source frame x)
(define (get n) (mk-source (procedure-properties-- frame '()) n))
(if x
(aif it (get (car x))
it
x)
(aif it (get 0)
it
x)))
(define* (print-frame frame #:optional (port (current-output-port))
#:key index (width ((R terminal-width))) (full? #f)
(last-source #f) next-source?)
(define (source:pretty-file source)
(if source
(or ((R source:file) source) "current input")
"unknown file"))
(let* ((source (frame-source frame ((R frame-source) frame)))
(file (source:pretty-file source))
(line (and=> source (R source:line-for-user)))
(col (and=> source (R source:column))))
(if (and file (not (equal? file (source:pretty-file last-source))))
(format port "~&In ~a:~&" file))
(format port "[email protected]~:[~*~3_~;~3d~] ~v:@y~%"
(if line (format #f "~a:~a" line col) "")
index index width
((R frame-call-representation) frame #:top-frame? (zero? index)))
(if full?
((R print-locals) frame #:width width
#:per-line-prefix " "))))
(define* (print-frames frames
#:optional (port (current-output-port))
#:key (width ((R terminal-width))) (full? #f)
(forward? #f) count)
(let* ((len (vector-length frames))
(lower-idx (if (or (not count) (positive? count))
0
(max 0 (+ len count))))
(upper-idx (if (and count (negative? count))
(1- len)
(1- (if count (min count len) len))))
(inc (if forward? 1 -1)))
(let lp ((i (if forward? lower-idx upper-idx))
(last-source #f))
(if (<= lower-idx i upper-idx)
(let* ((frame (vector-ref frames i)))
(print-frame frame port #:index i #:width width #:full? full?
#:last-source last-source)
(lp (+ i inc)
(frame-source frame ((R frame-source) frame))))))))
(define-set-R print-frame print-frame)
(define-set-R print-frames print-frames))
(guile-2.0
(values)))
def f(x):
pk(3,x)
if x: raise
raise
def g(x):
pk(4,x)
f(x)
raise
def h(x):
x
g(x)
raise
......@@ -139,4 +139,4 @@
((_)
(if the-exception
(apply throw (slask-it the-exception))
(raise Exception "annonymous")))))
(raise)))))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment