From: Joe Marshall <eval.apply@gmail.com>
Date: Thu, 24 May 2012 18:42:03 +0000 (-0700)
Subject: Add lambda-bound? procedure.
X-Git-Tag: release-9.2.0~247^2~3
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=711efc292d2da0e9b6f7c375da3060af93ac6b48;p=mit-scheme.git

Add lambda-bound? procedure.
---

diff --git a/src/runtime/lambda.scm b/src/runtime/lambda.scm
index b88a3bce3..3ce3c4825 100644
--- a/src/runtime/lambda.scm
+++ b/src/runtime/lambda.scm
@@ -32,6 +32,7 @@ USA.
 (define lambda-body)
 (define set-lambda-body!)
 (define lambda-bound)
+(define lambda-bound?)
 (define lambda-interface)
 (define lambda-name)
 
@@ -106,6 +107,11 @@ USA.
 		    clambda-bound
 		    clexpr-bound
 		    xlambda-bound))
+  (set! lambda-bound?
+	(dispatch-1 'LAMBDA-BOUND?
+		    clambda-bound?
+		    clexpr-bound?
+		    xlambda-bound?))
   (set! lambda-immediate-body
 	(dispatch-0 'LAMBDA-IMMEDIATE-BODY
 		    slambda-body
@@ -251,6 +257,10 @@ USA.
       name
       (append required (lambda-body-auxiliary body)))))
 
+(define (clambda-bound? clambda symbol)
+  (or (slambda-bound? clambda symbol)
+      (auxiliary-bound? (slambda-body clambda) symbol)))
+
 (define (clambda-has-internal-lambda? clambda)
   (lambda-body-has-internal-lambda? (slambda-body clambda)))
 
@@ -268,6 +278,12 @@ USA.
 	 (and (internal-lambda? operator)
 	      operator))))
 
+(define (auxiliary-bound? body symbol)
+  (and (combination? body)
+       (let ((operator (combination-operator body)))
+	 (and (internal-lambda? operator)
+	      (internal-lambda-bound? operator symbol)))))
+
 (define clambda-wrap-body!)
 (define clambda-wrapper-components)
 (define clambda-unwrap-body!)
@@ -308,6 +324,10 @@ USA.
 		(slambda-auxiliary internal)
 		(lambda-body-auxiliary (slambda-body internal)))))))
 
+(define (clexpr-bound? clexpr symbol)
+  (or (slexpr-bound? clexpr symbol)
+      (clexpr-internal-bound? clexpr symbol)))
+
 (define (clexpr-interface clexpr)
   (slexpr-components clexpr
     (lambda (name required body)
@@ -321,6 +341,13 @@ USA.
     (or (lambda-body-has-internal-lambda? (slambda-body internal))
 	internal)))
 
+(define (clexpr-internal-bound? clexpr symbol)
+  (let ((body (slexpr-body clexpr)))
+    (and (combination? body)
+	 (let ((operator (combination-operator body)))
+	   (and (internal-lambda? operator)
+		(internal-lambda-bound? operator symbol))))))
+
 (define (clexpr/physical-body clexpr)
   (slambda-body (clexpr-has-internal-lambda? clexpr)))
 
@@ -428,6 +455,12 @@ USA.
 	    (subvector->list names 1 (vector-length names)))
 	  (lambda-body-auxiliary (%xlambda-body xlambda))))
 
+(define (xlambda-bound? xlambda symbol)
+  (guarantee-xlambda xlambda 'xlambda-bound?)
+  (or (let ((bound (%xlambda-names-vector xlambda)))
+	(subvector-find-next-element bound 1 (vector-length bound) symbol))
+      (auxiliary-bound? (%xlambda-body xlambda) symbol)))
+
 (define (xlambda-has-internal-lambda? xlambda)
   (lambda-body-has-internal-lambda? (&triple-first xlambda)))
 
@@ -592,6 +625,10 @@ USA.
      #f
      '())))
 
+(define (slambda-bound? slambda symbol)
+  (let ((bound (%slambda-names-vector slambda)))
+    (subvector-find-next-element bound 1 (vector-length bound) symbol)))
+
 (define-integrable (%slambda-name slambda)
   (vector-ref (%slambda-names-vector slambda) 0))
 
@@ -629,6 +666,10 @@ USA.
 (define (slexpr-names-vector slexpr)
   (&pair-cdr slexpr))
 
+(define (slexpr-bound? slexpr symbol)
+  (let ((bound (&pair-cdr slexpr)))
+    (subvector-find-next-element bound 1 (vector-length bound) symbol)))
+
 (define-integrable (slexpr-name slexpr)
   (vector-ref (&pair-cdr slexpr) 0))
 
@@ -657,6 +698,10 @@ USA.
        (or (eq? (slambda-name *lambda) lambda-tag:internal-lambda)
 	   (eq? (slambda-name *lambda) lambda-tag:internal-lexpr))))
 
+(define (internal-lambda-bound? *lambda symbol)
+  (and (slambda? *lambda)
+       (slambda-bound? *lambda symbol)))
+
 (define (make-unassigned auxiliary)
   (map (lambda (auxiliary)
 	 auxiliary
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index c0e677c45..a52f9aed9 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2420,6 +2420,7 @@ USA.
 	  lambda?
 	  lambda-body
 	  lambda-bound
+	  lambda-bound?
 	  lambda-components
 	  lambda-interface
 	  lambda-name