Add lambda-bound? procedure.

diff --git a/src/runtime/lambda.scm b/src/runtime/lambda.scm
index b88a3bce389055f01ae422ddef0606066f5341c1..3ce3c48259760970b2f598d1596256d39fb7be24 100644 (file)
--- 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 c0e677c45f7785da189db9b3f1adedeaba94c26e..a52f9aed9a8a89856300c265b06fbd405a88ba7f 100644 (file)
--- 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