Handle reference traps and interpreter return addresses.

diff --git a/src/compiler/base/fasdump.scm b/src/compiler/base/fasdump.scm
index ccf09cf9695851f81b3123a2653f8286d89e7027..dceb63f5afb7f6483c5d4fb7e6a5f4dcdc6c7f50 100644 (file)
--- a/src/compiler/base/fasdump.scm
+++ b/src/compiler/base/fasdump.scm
@@ -1020,9 +1020,6 @@ USA.
 (define trap:unbound 2)
 (define trap-max-immediate 9)
 
-(define (reference-trap-kind trap)
-  (error 'reference-trap-kind trap))
-
 (define (reference-trap-extra trap)
   (error 'reference-trap-extra trap))
 \f

diff --git a/tests/compiler/test-fasdump.scm b/tests/compiler/test-fasdump.scm
index ceda794384c5c5a3143f50c04db242525c73d624..a80faa808b59ab62535eb065d09a070338420a83 100644 (file)
--- a/tests/compiler/test-fasdump.scm
+++ b/tests/compiler/test-fasdump.scm
@@ -43,6 +43,10 @@ USA.
                 (eqv? (flo:sign-negative? x) (flo:sign-negative? y))
                 (eqv? (flo:nan-quiet? x) (flo:nan-quiet? y))
                 (eqv? (flo:nan-payload x) (flo:nan-payload y))))
+          ((reference-trap? x)
+           (and (reference-trap? y)
+                (eqv? (reference-trap-kind x) (reference-trap-kind y))
+                (<= (reference-trap-kind x) trap-max-immediate)))
           ((scode-access? x)
            (and (scode-access? y)
                 (loop (scode-access-environment x)
@@ -217,8 +221,8 @@ USA.
     (xyz)
     ;; XXX uninterned symbols
     (,(make-primitive-procedure 'quagga 42))
-    ;; XXX reference trap
-    ;; XXX interpreter return address, wtf?
+    (,(make-unassigned-reference-trap))
+    (,(make-return-address 42))
     (#\U+0)
     (#\0)
     (#\U+1000)
@@ -277,7 +281,10 @@ USA.
             (lambda (pathname)
               (let ((format fasdump-format:amd64))
                 (portable-fasdump object pathname format))
-              (let ((object* (fasload pathname)))
+              (let ((object*
+                     (map-reference-trap
+                      (lambda ()
+                        (fasload pathname)))))
                 (if (not (equal-nan-scode? object object*))
                     (begin
                       (pp 'fail)