diff options
Diffstat (limited to 'module/system/vm/frame.scm')
-rw-r--r-- | module/system/vm/frame.scm | 113 |
1 files changed, 95 insertions, 18 deletions
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm index 29a612b44..7a09a6275 100644 --- a/module/system/vm/frame.scm +++ b/module/system/vm/frame.scm @@ -20,12 +20,19 @@ ;;; Code: (define-module (system vm frame) - :use-module ((system vm core) :renamer (symbol-prefix-proc 'vm:)) + :use-module (system vm program) :export (frame-number frame-address - vm-current-frame-chain vm-last-frame-chain - print-frame print-frame-call)) + print-frame print-frame-call + frame-arguments frame-local-variables frame-external-variables + frame-environment + frame-variable-exists? frame-variable-ref frame-variable-set! + frame-object-name + frame-local-ref frame-external-link frame-local-set! + frame-return-address frame-program + frame-dynamic-link frame?)) + +(dynamic-call "scm_init_frames" (dynamic-link "libguile-vm")) - ;;; ;;; Frame chain ;;; @@ -33,21 +40,15 @@ (define frame-number (make-object-property)) (define frame-address (make-object-property)) -(define (vm-current-frame-chain vm) - (make-frame-chain (vm:vm-this-frame vm) (vm:vm:ip vm))) - -(define (vm-last-frame-chain vm) - (make-frame-chain (vm:vm-last-frame vm) (vm:vm:ip vm))) - (define (make-frame-chain frame addr) - (let* ((link (vm:frame-dynamic-link frame)) + (let* ((link (frame-dynamic-link frame)) (chain (if (eq? link #t) '() (cons frame (make-frame-chain - link (vm:frame-return-address frame)))))) + link (frame-return-address frame)))))) (set! (frame-number frame) (length chain)) (set! (frame-address frame) - (- addr (program-base (vm:frame-program frame)))) + (- addr (program-base (frame-program frame)))) chain)) @@ -56,7 +57,7 @@ ;;; (define (print-frame frame) - (format #t "#~A " (vm:frame-number frame)) + (format #t "#~A " (frame-number frame)) (print-frame-call frame) (newline)) @@ -72,12 +73,88 @@ (else (vector (abbrev (vector-ref x 0)) '...)))) (else x))) (write (abbrev (cons (program-name frame) - (vm:frame-arguments frame))))) + (frame-arguments frame))))) (define (program-name frame) - (let ((prog (vm:frame-program frame)) - (link (vm:frame-dynamic-link frame))) + (let ((prog (frame-program frame)) + (link (frame-dynamic-link frame))) (or (object-property prog 'name) - (vm:frame-object-name link (1- (vm:frame-address link)) prog) + (frame-object-name link (1- (frame-address link)) prog) (hash-fold (lambda (s v d) (if (eq? prog (variable-ref v)) s d)) prog (module-obarray (current-module)))))) + + +;;; +;;; Frames +;;; + +(define (frame-arguments frame) + (let* ((prog (frame-program frame)) + (arity (program-arity prog))) + (do ((n (+ (arity:nargs arity) -1) (1- n)) + (l '() (cons (frame-local-ref frame n) l))) + ((< n 0) l)))) + +(define (frame-local-variables frame) + (let* ((prog (frame-program frame)) + (arity (program-arity prog))) + (do ((n (+ (arity:nargs arity) (arity:nlocs arity) -1) (1- n)) + (l '() (cons (frame-local-ref frame n) l))) + ((< n 0) l)))) + +(define (frame-external-variables frame) + (frame-external-link frame)) + +(define (frame-external-ref frame index) + (list-ref (frame-external-link frame) index)) + +(define (frame-external-set! frame index val) + (list-set! (frame-external-link frame) index val)) + +(define (frame-binding-ref frame binding) + (if (binding:extp binding) + (frame-external-ref frame (binding:index binding)) + (frame-local-ref frame (binding:index binding)))) + +(define (frame-binding-set! frame binding val) + (if (binding:extp binding) + (frame-external-set! frame (binding:index binding) val) + (frame-local-set! frame (binding:index binding) val))) + +(define (frame-bindings frame addr) + (do ((bs (program-bindings (frame-program frame)) (cdr bs)) + (ls '() (if (cdar bs) (cons (cdar bs) ls) (cdr ls)))) + ((or (null? bs) (> (caar bs) addr)) + (apply append ls)))) + +(define (frame-lookup-binding frame addr sym) + (do ((bs (frame-bindings frame addr) (cdr bs))) + ((or (null? bs) (eq? sym (binding:name (car bs)))) + (and (pair? bs) (car bs))))) + +(define (frame-object-binding frame addr obj) + (do ((bs (frame-bindings frame addr) (cdr bs))) + ((or (null? bs) (eq? obj (frame-binding-ref frame (car bs)))) + (and (pair? bs) (car bs))))) + +(define (frame-environment frame addr) + (map (lambda (binding) + (cons (binding:name binding) (frame-binding-ref frame binding))) + (frame-bindings frame addr))) + +(define (frame-variable-exists? frame addr sym) + (if (frame-lookup-binding frame addr sym) #t #f)) + +(define (frame-variable-ref frame addr sym) + (cond ((frame-lookup-binding frame addr sym) => + (lambda (binding) (frame-binding-ref frame binding))) + (else (error "Unknown variable:" sym)))) + +(define (frame-variable-set! frame addr sym val) + (cond ((frame-lookup-binding frame addr sym) => + (lambda (binding) (frame-binding-set! frame binding val))) + (else (error "Unknown variable:" sym)))) + +(define (frame-object-name frame addr obj) + (cond ((frame-object-binding frame addr obj) => binding:name) + (else #f))) |