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.scm27
1 files changed, 23 insertions, 4 deletions
diff --git a/module/system/vm/frame.scm b/module/system/vm/frame.scm
index ccfc05745..15e745d18 100644
--- a/module/system/vm/frame.scm
+++ b/module/system/vm/frame.scm
@@ -33,6 +33,7 @@
binding-slot
binding-representation
+ frame-instruction-pointer-or-primitive-procedure-name
frame-bindings
frame-lookup-binding
frame-binding-ref frame-binding-set!
@@ -40,6 +41,10 @@
frame-environment
frame-object-binding frame-object-name))
+(eval-when (expand compile load eval)
+ (load-extension (string-append "libguile-" (effective-version))
+ "scm_init_frames_builtins"))
+
(define-record-type <binding>
(make-binding idx name slot representation)
binding?
@@ -300,14 +305,18 @@
(lp (cdr bindings))))))
(define (frame-binding-set! frame var val)
- (let ((binding (or (frame-lookup-binding frame var)
- (error "variable not bound in frame" var frame))))
+ (let ((binding (if (binding? var)
+ var
+ (or (frame-lookup-binding frame var)
+ (error "variable not bound in frame" var frame)))))
(frame-local-set! frame (binding-slot binding) val
(binding-representation binding))))
(define (frame-binding-ref frame var)
- (let ((binding (or (frame-lookup-binding frame var)
- (error "variable not bound in frame" var frame))))
+ (let ((binding (if (binding? var)
+ var
+ (or (frame-lookup-binding frame var)
+ (error "variable not bound in frame" var frame)))))
(frame-local-ref frame (binding-slot binding)
(binding-representation binding))))
@@ -340,6 +349,16 @@
(define (frame-arguments frame)
(cdr (frame-call-representation frame)))
+;; Usually the IP is sufficient to identify the procedure being called.
+;; However all primitive applications of the same arity share the same
+;; code. Perhaps we should change that in the future, but for now we
+;; export this function to avoid having to export frame-local-ref.
+;;
+(define (frame-instruction-pointer-or-primitive-procedure-name frame)
+ (let ((ip (frame-instruction-pointer frame)))
+ (if (primitive-code? ip)
+ (procedure-name (frame-local-ref frame 0 'scm))
+ ip)))
;;;