From 02370f6018a54d3e4334e0671c6ec41d8b589e8a Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 28 May 2018 18:22:13 -0700
Subject: [PATCH] Implement make-promise for R7RS.

Also clean up promise implementation a bit.
---
 src/runtime/framex.scm         | 10 +++---
 src/runtime/microcode-data.scm | 57 +++++++++++++++++-----------------
 src/runtime/rep.scm            |  1 -
 src/runtime/runtime.pkg        | 12 +++----
 4 files changed, 40 insertions(+), 40 deletions(-)

diff --git a/src/runtime/framex.scm b/src/runtime/framex.scm
index 986abe904..e493faeb1 100644
--- 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 f487de259..bdeb69f86 100644
--- 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 24035f413..955f474e7 100644
--- 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 342a12b3c..7925f3654 100644
--- 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")
-- 
2.25.1