Implement make-promise for R7RS.

Also clean up promise implementation a bit.

diff --git a/src/runtime/framex.scm b/src/runtime/framex.scm
index 986abe90455aa6ea27eecb0bb0115088db0cb361..e493faeb1f1dd1a88a62f1731d33f7c8a9f26fb8 100644 (file)
--- a/src/runtime/framex.scm
+++ b/src/runtime/framex.scm
@@ -133,11 +133,11 @@ USA.
     (values (make-scode-combination (ucode-primitive force 1)
                                    (list (make-evaluated-object promise)))
            undefined-environment
-           (cond ((promise-forced? promise) undefined-expression)
-                 ((promise-non-expression? promise) unknown-expression)
-                 (else
-                  (validate-subexpression frame
-                                          (promise-expression promise)))))))
+           (let ((expr (promise-expression promise)))
+             (case expr
+               ((|#[(runtime microcode-data)forced]|) undefined-expression)
+               ((|#[(runtime microcode-data)compiled]|) unknown-expression)
+               (else (validate-subexpression frame expr)))))))
 
 (define ((method/application-frame index) frame)
   (values (make-scode-combination

diff --git a/src/runtime/microcode-data.scm b/src/runtime/microcode-data.scm
index f487de259d34e4b233eeccee6afd586fb510bfc4..bdeb69f86f4ce1918b302cfb59dec7ccd13f18b0 100644 (file)
--- a/src/runtime/microcode-data.scm
+++ b/src/runtime/microcode-data.scm
@@ -263,42 +263,43 @@ contains constants derived from the source program.
 (define-integrable (promise? object)
   (object-type? (ucode-type delayed) object))
 
-(define-guarantee promise "promise")
+(define (make-promise object)
+  (if (promise? object)
+      object
+      (system-pair-cons (ucode-type delayed) #t object)))
 
-(define-integrable (promise-forced? promise)
+(define-integrable (%promise-forced? promise)
   (eq? #t (system-pair-car promise)))
 
-(define-integrable (promise-non-expression? promise)
-  (eqv? 0 (system-pair-car promise)))
+(define (promise-forced? promise)
+  (guarantee promise? promise 'promise-forced?)
+  (%promise-forced? promise))
 
 (define (promise-value promise)
-  (if (not (promise-forced? promise))
-      (error "Promise not yet forced" promise))
+  (guarantee promise? promise 'promise-value)
+  (if (not (%promise-forced? promise))
+      (error "Promise not yet forced:" promise))
   (system-pair-cdr promise))
 
 (define (promise-expression promise)
-  (if (promise-forced? promise)
-      (error "Promise already forced" promise))
-  (if (promise-non-expression? promise)
-      (error "Promise has no expression" promise))
-  (system-pair-cdr promise))
-
-(define (promise-environment promise)
-  (if (promise-forced? promise)
-      (error "Promise already forced" promise))
-  (if (promise-non-expression? promise)
-      (error "Promise has no environment" promise))
-  (system-pair-car promise))
+  (without-interrupts
+   (lambda ()
+     (case (system-pair-car promise)
+       ((#t) '|#[(runtime microcode-data)forced]|)
+       ((0) '|#[(runtime microcode-data)compiled]|)
+       (else (system-pair-cdr promise))))))
 
 (define (force promise)
   (guarantee promise? promise 'force)
-  (case (system-pair-car promise)
-    ((#t)
-     (system-pair-cdr promise))
-    ((0)                               ;compiled promise
-     (let ((result ((system-pair-cdr promise))))
-       (system-pair-set-cdr! promise result)
-       (system-pair-set-car! promise #t)
-       result))
-    (else                              ;losing old style
-     ((ucode-primitive force 1) promise))))
\ No newline at end of file
+  (without-interrupts
+   (lambda ()
+     (case (system-pair-car promise)
+       ((#t)
+       (system-pair-cdr promise))
+       ((0)                            ;compiled
+       (let ((result ((system-pair-cdr promise))))
+         (system-pair-set-cdr! promise result)
+         (system-pair-set-car! promise #t)
+         result))
+       (else                           ;interpreted
+       ((ucode-primitive force 1) promise))))))
\ No newline at end of file

diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm
index 24035f413fffa5af3eec311b75485b03a24a9f40..955f474e757eb206469b49b2d390fb9f2aab0998 100644 (file)
--- a/src/runtime/rep.scm
+++ b/src/runtime/rep.scm
@@ -799,7 +799,6 @@ USA.
     (cond ((environment? object) object)
          ((package? object) (package/environment object))
          ((procedure? object) (procedure-environment object))
-         ((promise? object) (promise-environment object))
          (else
           (let ((package
                  (let ((package-name

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 342a12b3cceaddffcee9b0ea4d71c6725ec540e2..7925f3654162641745893ec89e524908e1a3793a 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -806,19 +806,17 @@ USA.
          environment-extension-parent
          environment-extension-procedure
          environment-extension?
-         force
+         force                         ;R7RS
          interpreter-return-address?
+         make-promise                  ;R7RS
          make-return-address
          microcode-error
          microcode-return
          microcode-termination
          microcode-type
-         promise-environment
-         promise-expression
          promise-forced?
-         promise-non-expression?
          promise-value
-         promise?
+         promise?                      ;R7RS
          return-address/code
          return-address/name
          return-address?
@@ -826,7 +824,9 @@ USA.
          set-environment-extension-parent!
          stack-address->index
          stack-address-offset
-         stack-address?))
+         stack-address?)
+  (export (runtime debugging-info)
+         promise-expression))
 
 (define-package (runtime vector)
   (files "vector")