From: Chris Hanson <org/chris-hanson/cph>
Date: Fri, 3 Jul 1987 18:54:07 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~13298
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=15ba5619de8dd9eb042feeb622324cc43731e062;p=mit-scheme.git

Initial revision
---

diff --git a/v7/src/compiler/fggen/declar.scm b/v7/src/compiler/fggen/declar.scm
new file mode 100644
index 000000000..0b0d50a4e
--- /dev/null
+++ b/v7/src/compiler/fggen/declar.scm
@@ -0,0 +1,118 @@
+#| -*-Scheme-*-
+
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/fggen/declar.scm,v 1.1 1987/07/03 18:54:07 cph Exp $
+
+Copyright (c) 1987 Massachusetts Institute of Technology
+
+This material was developed by the Scheme project at the Massachusetts
+Institute of Technology, Department of Electrical Engineering and
+Computer Science.  Permission to copy this software, to redistribute
+it, and to use it for any purpose is granted, subject to the following
+restrictions and understandings.
+
+1. Any copy made of this software must include this copyright notice
+in full.
+
+2. Users of this software agree to make their best efforts (a) to
+return to the MIT Scheme project any improvements or extensions that
+they make, so that these may be included in future releases; and (b)
+to inform MIT of noteworthy uses of this software.
+
+3. All materials developed as a consequence of the use of this
+software shall duly acknowledge such use, in accordance with the usual
+standards of acknowledging credit in academic research.
+
+4. MIT has made no warrantee or representation that the operation of
+this software will be error-free, and MIT is under no obligation to
+provide any services, by way of maintenance, update, or otherwise.
+
+5. In conjunction with products arising from the use of this material,
+there shall be no use of the name of the Massachusetts Institute of
+Technology nor of any adaptation thereof in any advertising,
+promotional, or sales literature without prior written consent from
+MIT in each case. |#
+
+;;;; Flow Graph Generation: Declarations
+
+(declare (usual-integrations))
+
+(define (process-declarations! block declarations)
+  (for-each (lambda (declaration)
+	      (process-declaration! block declaration))
+	    declarations))
+
+(define (process-declaration! block declaration)
+  (let ((entry (assq (car declaration) known-declarations)))
+    (if entry
+	((cdr entry) block (car declaration) (cdr declaration))
+	(warn "Unknown declaration name" (car declaration)))))
+
+(define known-declarations
+  '())
+
+(define (define-declaration keyword handler)
+  (let ((entry (assq keyword known-declarations)))
+    (if entry
+	(set-cdr! entry handler)
+	(set! known-declarations
+	      (cons (cons keyword handler)
+		    known-declarations))))
+  keyword)
+
+(package (boolean-variable-property)
+
+(define-export (boolean-variable-property block keyword body)
+  (if (and (pair? body) (null? (cdr body)))
+      (for-each (lambda (variable)
+		  (if (not (memq keyword (variable-declarations variable)))
+		      (set-variable-declarations!
+		       variable
+		       (cons keyword (variable-declarations variable)))))
+		(evaluate-variable-specification block (car body)))
+      (warn "Misformed declaration" (cons keyword body))))
+
+(define (evaluate-variable-specification block specification)
+  (let loop ((specification specification))
+    (cond ((eq? specification 'BOUND) (block-bound-variables block))
+	  ((eq? specification 'FREE) (block-free-variables block))
+	  ((and (pair? specification)
+		(assq (car specification) binary-operators)
+		(pair? (cdr specification))
+		(pair? (cddr specification))
+		(null? (cdddr specification)))
+	   ((cdr (assq (car specification) binary-operators))
+	    (loop (cadr specification))
+	    (loop (caddr specification))))
+	  ((and (pair? specification)
+		(eq? (car specification) 'SET)
+		(symbol-list? (cdr specification)))
+	   (let loop ((symbols (cdr specification)))
+	     (if (null? symbols)
+		 '()
+		 (let ((entry
+			(or (variable-assoc (car symbols)
+					    (block-bound-variables block))
+			    (variable-assoc (car symbols)
+					    (block-free-variables block)))))
+		   (if entry
+		       (cons entry (loop (cdr symbols)))
+		       (loop (cdr symbols)))))))
+	  (else
+	   (warn "Misformed variable specification" specification)
+	   '()))))
+
+(define binary-operators
+  `((DIFFERENCE . ,eq-set-difference)
+    (INTERSECTION . ,eq-set-intersection)
+    (UNION . ,eq-set-union)))
+
+(define (symbol-list? object)
+  (or (null? object)
+      (and (pair? object)
+	   (symbol? (car object))
+	   (symbol-list? (cdr object)))))
+
+)
+
+(define-declaration 'UUO-LINK boolean-variable-property)
+(define-declaration 'CONSTANT boolean-variable-property)
\ No newline at end of file