summaryrefslogtreecommitdiff
path: root/module/system/vm/frame.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/system/vm/frame.scm')
-rw-r--r--module/system/vm/frame.scm113
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)))