From fedc9ae8f93f7b3e8cb82d3aae7e22c9bc397795 Mon Sep 17 00:00:00 2001
From: Stephen Adams <edu/mit/csail/zurich/adams>
Date: Tue, 4 Jul 1995 18:15:58 +0000
Subject: [PATCH] Implemented the COMPILE-BOOLEAN-PROPERTY procedure to check
 the syntax of an IGNORE-REFERENCE-TRAPS or IGNORE-ASSIGNMENT-TRAPS
 declaration specification and compile it into a predicate.

---
 v8/src/compiler/midend/utils.scm | 47 +++++++++++++++++++++++++++++++-
 1 file changed, 46 insertions(+), 1 deletion(-)

diff --git a/v8/src/compiler/midend/utils.scm b/v8/src/compiler/midend/utils.scm
index d58e5df22..3818abf33 100644
--- a/v8/src/compiler/midend/utils.scm
+++ b/v8/src/compiler/midend/utils.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: utils.scm,v 1.25 1995/05/06 18:28:45 adams Exp $
+$Id: utils.scm,v 1.26 1995/07/04 18:15:58 adams Exp $
 
 Copyright (c) 1994-1995 Massachusetts Institute of Technology
 
@@ -1208,3 +1208,48 @@ Example use of FORM/COPY-TRANSFORMING:
 	   (+ size 1))
 	  (else
 	   (walk (car program) (walk (cdr program) (+ size 1)))))))
+
+;; (compile-boolean-property expr env bound? free? assigned?)
+;;   -> #F  or  name -> Bool
+;;
+;; bound?, free?, assigned? : (env * name -> Bool) or #F
+;;
+
+(define (compile-boolean-property expr env bound? free? assigned?)
+
+  (let compile ((expr expr))
+    (define (binary-operator? tag operate)
+      (and (list? expr)
+	   (= (length expr) 3)
+	   (eq? (car expr) tag)
+	   (let ((a (compile (second expr)))
+		 (b (compile (third expr))))
+	     (and a b (operate a b)))))
+    (define-integrable (environment-query predicate?)
+      (and predicate?
+	   (lambda (name)
+	     (predicate? env name))))
+    (cond ((eq? expr 'NONE)     (lambda (name) name #F))
+	  ((eq? expr 'ALL)      (lambda (name) name #T))
+	  ((eq? expr 'FREE)     (environment-query free?))
+	  ((eq? expr 'BOUND)    (environment-query bound?))
+	  ((eq? expr 'ASSIGNED) (environment-query assigned?))
+	  ((not (pair? expr))   #F)
+	  ((and (eq? (car expr) 'SET)
+		(list? expr)
+		(for-all? expr symbol?)
+		(lambda (name)
+		  (memq name (cdr expr)))))
+	  ((binary-operator? 'UNION
+			     (lambda (a b)
+			       (lambda (name)
+				 (or (a name) (b name))))))
+	  ((binary-operator? 'DIFFERENCE
+			     (lambda (a b)
+			       (lambda (name)
+				 (and (a name) (not (b name)))))))
+	  ((binary-operator? 'INTERSECTION
+			     (lambda (a b)
+			       (lambda (name)
+				 (and (a name) (b name))))))
+	  (else #F))))
\ No newline at end of file
-- 
2.25.1