better source description in backtraces

parent 165d33db
(define-module (language python adress)
#:use-module (system vm program)
#:use-module (system vm frame)
#:export (procedure-properties-- set-procedure-properties!--
set-procedure-property!--))
(define-syntax-rule (aif it p . l) (let ((it p)) (if it . l)))
(define root (vector 0 0 0 0 #f #f #f))
(define-syntax-rule (xl x) (vector-ref x 4))
(define-syntax-rule (xr x) (vector-ref x 5))
(define-syntax-rule (l1 x) (vector-ref x 0))
(define-syntax-rule (l2 x) (vector-ref x 1))
(define-syntax-rule (r1 x) (vector-ref x 3))
(define-syntax-rule (r2 x) (vector-ref x 2))
(define-syntax-rule (v x) (vector-ref x 6))
(define-syntax-rule (xlset x v) (vector-set! x 4 v))
(define-syntax-rule (xrset x v) (vector-set! x 5 v))
(define-syntax-rule (l1set x v) (vector-set! x 0 v))
(define-syntax-rule (l2set x v) (vector-set! x 1 v))
(define-syntax-rule (r1set x v) (vector-set! x 3 v))
(define-syntax-rule (r2set x v) (vector-set! x 2 v))
(define-syntax-rule (vset x v) (vector-set! x 6 v))
(define frame? (@@ (system vm frame) frame?))
(define frame-address (@@ (system vm frame) frame-instruction-pointer))
(define (lookup addr fail)
(let lp ((ro root))
(cond
((< addr (l2 ro))
(aif it (xl ro)
(lp it)
fail))
((> addr (r2 ro))
(aif it (xr ro)
(lp it)
fail))
((and (>= addr (l2 ro)) (<= addr (r2 ro)))
(if (eq? ro root)
fail
(v ro)))
(else
fail))))
(define (add a1 a2 val)
(let lp ((ro root))
(cond
((< a2 (l2 ro))
(aif it (xl ro)
(call-with-values (lambda () (lp it))
(lambda (ll rr)
(l1set ro ll)
(l2set ro (max rr (l2 ro)))
(values ll (r1 ro))))
(begin
(l1set ro a1)
(l2set ro (max a2 (l2 ro)))
(xlset ro (vector a1 a1 a2 a2 #f #f val))
(values a1 (r2 ro)))))
((> a1 (r2 ro))
(aif it (xr ro)
(call-with-values (lambda () (lp it))
(lambda (ll rr)
(r2set ro (min ll (r2 ro)))
(r1set ro rr)
(values (l1 ro) rr)))
(begin
(r2set ro (min a1 (r2 ro)))
(r1set ro a2)
(xrset ro (vector a1 a1 a2 a2 #f #f val))
(values (l1 ro) a2))))
(else
(vset ro val)
(values (l1 ro) (r1 ro))))))
(define (procedure-properties-- x fail)
(let lp ((x x))
(cond
((program? x)
(lp (car (program-address-range x))))
((frame? x)
(lp (frame-address x)))
(else
(lookup x fail)))))
(define (set-procedure-properties!-- x v)
(if (program? x)
(let* ((l.r (program-address-range x))
(l (car l.r))
(r (- (cdr l.r) 1)))
(add l r v)
(values))))
(define (set-procedure-property!-- x k v)
(let ((w (procedure-properties-- x '())))
(set-procedure-properties!-- x (cons (cons k v) w))))
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