From: Joe Marshall <eval.apply@gmail.com>
Date: Mon, 28 Mar 2011 17:41:18 +0000 (-0700)
Subject: Add and export GUARANTEE-PROMISE.
X-Git-Tag: 20110426-Gtk~2^2~26^2
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=6de9b1a2dbaf602b6e928178cc860fc22ada6184;p=mit-scheme.git

Add and export GUARANTEE-PROMISE.
---

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 836b5c91a..d81887c41 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -698,6 +698,7 @@ USA.
 	  environment-extension-procedure
 	  environment-extension?
 	  force
+	  guarantee-promise
 	  interpreter-return-address?
 	  make-return-address
 	  microcode-error
diff --git a/src/runtime/udata.scm b/src/runtime/udata.scm
index d79fd9696..8f56c44da 100644
--- a/src/runtime/udata.scm
+++ b/src/runtime/udata.scm
@@ -262,6 +262,8 @@ contains constants derived from the source program.
 (define-integrable (promise? object)
   (object-type? (ucode-type delayed) object))
 
+(define-guarantee promise "promise")
+
 (define-integrable (promise-forced? promise)
   (eq? #t (system-pair-car promise)))
 
@@ -288,8 +290,7 @@ contains constants derived from the source program.
   (system-pair-car promise))
 
 (define (force promise)
-  (if (not (promise? promise))
-      (error:wrong-type-argument promise "promise" 'FORCE))
+  (guarantee-promise promise 'FORCE)
   (case (system-pair-car promise)
     ((#T)
      (system-pair-cdr promise))