From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001
From: Yale AI Dept <ai@nebula.cs.yale.edu>
Date: Wed, 14 Jul 1993 13:08:00 -0500
Subject: Import to github.

---
 prec/scope.scm | 367 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 367 insertions(+)
 create mode 100644 prec/scope.scm

(limited to 'prec/scope.scm')

diff --git a/prec/scope.scm b/prec/scope.scm
new file mode 100644
index 0000000..e57ed64
--- /dev/null
+++ b/prec/scope.scm
@@ -0,0 +1,367 @@
+;;; scope.scm -- variable scoping and precedence parsing phase
+;;; 
+;;; author :  John & Sandra
+;;; date   :  11 Feb 1992
+;;;
+;;;
+
+
+;;;===================================================================
+;;; Basic support
+;;;===================================================================
+
+(define (scope-modules modules)
+  (walk-modules modules
+    (lambda ()
+      (setf (module-decls *module*) (scope-ast-decls (module-decls *module*)))
+      (dolist (a (module-annotations *module*))
+;;; This is currently bogus since it assumes only vars are annotated.	      
+	 (when (annotation-decl? a)
+	   (dolist (n (annotation-decl-names a))
+	      (let ((v (table-entry *symbol-table* n)))
+		(when (or (eq? v '#f) (not (var? v)))
+		  (fatal-error 'unknown-annotation-name
+			       "~A: not a var in annotation decl~%" n))
+		(when (not (eq? (def-module v) *module-name*))
+		  (fatal-error 'non-local-name-in-annotation
+			       "~A: not a local var in annotation decl~%" n))
+		(setf (var-annotations v)
+		      (append (var-annotations v)
+			      (annotation-decl-annotations a))))))))))
+
+;;; Define the basic walker and some helper functions.
+
+(define-walker scope ast-td-scope-walker)
+
+(define (scope-ast-1 x env)
+;  (call-walker scope x env))
+  (remember-context x
+    (call-walker scope x env)))
+
+
+(define (scope-ast/list l env)
+  (scope-ast/list-aux l env)
+  l)
+
+(define (scope-ast/list-aux l env)
+  (when (not (null? l))
+    (setf (car l) (scope-ast-1 (car l) env))
+    (scope-ast/list-aux (cdr l) env)))
+
+;;; This filters out signdecls from decl lists.  These declarations are moved
+;;; into the var definitions.
+
+(define (scope-ast/decl-list l env)
+  (if (null? l)
+      '()
+      (let ((x (scope-ast-1 (car l) env))
+	    (rest (scope-ast/decl-list (cdr l) env)))
+	(if (or (annotation-decls? x)
+		(and (signdecl? x)
+		     (not (eq? (module-type *module*) 'interface))))
+	    rest
+	    (begin
+	      (setf (car l) x)
+	      (setf (cdr l) rest)
+	      l)))))
+
+;;; This is the main entry point.  It is called by the driver
+;;; on each top-level decl in the module.
+
+(define (scope-ast-decls x)
+  (let ((result  (scope-ast/decl-list x '())))
+;    (pprint result)   ;*** debug
+    result))
+
+
+;;; All top-level names are entered in the *symbol-table* hash table.
+;;; This is done by the import/export phase of the compiler before
+;;; we get here.
+;;; The env is a list of a-lists that associates locally-defined names with
+;;; their definitions.  Each nested a-list corresponds to a "level" or
+;;; scope.
+;;; *** If many variables are being added in each scope, it might be
+;;; *** better to use a table instead of an alist to represent each contour.
+
+(define (lookup-name name env)
+  (if (null? env)
+      (lookup-toplevel-name name)
+      (let ((info  (assq name (car env))))
+	(if info
+	    (cdr info)
+	    (lookup-name name (cdr env))))))
+
+
+;;; Some kinds of names (e.g. type definitions) appear only at top-level,
+;;; so use this to look for them directly.
+
+(define (lookup-toplevel-name name)
+  (or (resolve-toplevel-name name)
+      (begin
+        (signal-undefined-symbol name)
+	*undefined-def*)))
+
+
+;;; Some kinds of lookups (e.g., matching a signature declaration)
+;;; require that the name be defined in the current scope and not
+;;; an outer one.  Use this function.
+
+(define (lookup-local-name name env)
+  (if (null? env)
+      (lookup-toplevel-name name)
+      (let ((info  (assq name (car env))))
+	(if info
+	    (cdr info)
+	    (begin
+	      (signal-undefined-local-symbol name)
+	      *undefined-def*)))))
+
+
+;;; Add local declarations to the environment, returning a new env.
+;;; Do not actually walk the local declarations here.
+
+(define *scope-info* '())
+
+(define (add-local-declarations decls env)
+  (if (null? decls)
+      env
+      (let ((contour   '()))
+	(dolist (d decls)
+	  (if (is-type? 'valdef d)
+	      (setf contour
+		    (add-bindings (collect-pattern-vars (valdef-lhs d))
+				  contour))))
+	(cons contour env))))
+
+
+;;; Similar, but for adding lambda and function argument bindings to the
+;;; environment.
+
+(define (add-pattern-variables patterns env)
+  (if (null? patterns)
+      env
+      (let ((contour   '()))
+	(dolist (p patterns)
+	  (setf contour (add-bindings (collect-pattern-vars p) contour)))
+	(cons contour env))))
+
+
+;;; Given a list of var-refs, create defs for them and add them to
+;;; the local environment.
+;;; Also check to see that there are no duplicates.
+
+(define (add-bindings var-refs contour)
+  (dolist (v var-refs)
+   (when (eq? (var-ref-var v) *undefined-def*)
+    (let* ((name     (var-ref-name v))
+	   (def      (create-local-definition name)))
+      (setf (var-ref-var v) def)
+      (if (assq name contour)
+	  (signal-multiple-bindings name)
+	  (push (cons name def) contour)))))
+  contour)
+
+
+;;; Error signalling utilities.
+
+(define (signal-undefined-local-symbol name)
+  (phase-error 'undefined-local-symbol
+    "The name ~a has no definition in the current scope."
+    name))
+
+(define (signal-multiple-signatures name)
+  (phase-error 'multiple-signatures
+    "There are multiple signatures for the name ~a."
+    name))
+
+(define (signal-multiple-bindings name)
+  (phase-error 'multiple-bindings
+    "The name ~a appears more than once in a function or pattern binding."
+    name))
+  
+
+
+;;;===================================================================
+;;; Default traversal methods
+;;;===================================================================
+
+
+(define-local-syntax (make-scope-code slot type)
+  (let ((stype  (sd-type slot))
+	(sname  (sd-name slot)))
+    (cond ((and (symbol? stype)
+		(or (eq? stype 'exp)
+		    (subtype? stype 'exp)))
+	   `(setf (struct-slot ',type ',sname object)
+		  (scope-ast-1 (struct-slot ',type ',sname object) env)))
+	  ((and (pair? stype)
+		(eq? (car stype) 'list)
+		(symbol? (cadr stype))
+		(or (eq? (cadr stype) 'exp)
+		    (subtype? (cadr stype) 'exp)))
+	   `(setf (struct-slot ',type ',sname object)
+		  (scope-ast/list (struct-slot ',type ',sname object) env)))
+	  (else
+;	   (format '#t "Scope: skipping slot ~A in ~A~%"
+;		   (sd-name slot)
+;		   type)
+	   '#f))))
+
+
+(define-modify-walker-methods scope
+  (guarded-rhs  ; exp slots
+   if           ; exp slots
+   app          ; exp slots
+   integer-const float-const char-const string-const  ; no slots
+   list-exp     ; (list exp) slot
+   sequence sequence-to sequence-then sequence-then-to ; exp slots
+   section-l section-r ; exp slots
+   omitted-guard overloaded-var-ref ; no slots
+   negate ; no slots
+   sel
+   prim-definition
+   con-number cast
+   )
+  (object env)
+  make-scope-code)
+
+
+;;;===================================================================
+;;; valdef-structs
+;;;===================================================================
+
+
+;;; Signature declarations must appear at the same level as the names
+;;; they apply to.  There must not be more than one signature declaration
+;;; applying to a given name.
+
+(define-walker-method scope signdecl (object env)
+  (let ((signature  (signdecl-signature object)))
+    (resolve-signature signature)
+    (let ((gtype (ast->gtype (signature-context signature)
+			     (signature-type signature))))
+      (dolist (v (signdecl-vars object))
+	(when (eq? (var-ref-var v) *undefined-def*)
+	      (setf (var-ref-var v)
+		    (lookup-local-name (var-ref-name v) env)))
+	(let ((def  (var-ref-var v)))
+	  (when (not (eq? def *undefined-def*))
+	    ;; The lookup-local-name may fail if there is a program error.
+	    ;; In that case, skip this.
+	    (if (var-signature def)
+		(signal-multiple-signatures (var-ref-name v))
+		(setf (var-signature def) gtype))))))
+    object))
+
+;;; This attaches annotations to locally defined vars in the same
+;;; manner as signdecl annotations.
+
+(define-walker-method scope annotation-decls (object env)
+  (let ((anns (annotation-decls-annotations object)))
+    (dolist (a anns)
+      (cond ((annotation-value? a)
+	     (recoverable-error 'unknown-annotation "Unknown annotation: ~A" a))
+	    ((annotation-decl? a)
+	     (dolist (v (annotation-decl-names a))
+	       (let ((name (lookup-local-name v env)))
+		 (when (not (eq? name *undefined-def*))
+		   (setf (var-annotations name)
+			 (append (var-annotations name)
+			      (annotation-decl-annotations a))))))))))
+  object)
+
+(define-walker-method scope exp-sign (object env)
+  (resolve-signature (exp-sign-signature object))
+  (setf (exp-sign-exp object) (scope-ast-1 (exp-sign-exp object) env))
+  object)
+
+;;; By the time we get to walking a valdef, all the variables it
+;;; declares have been entered into the environment.  All we need to
+;;; do is massage the pattern and recursively walk the definitions.
+
+(define-walker-method scope valdef (object env)
+  (setf (valdef-module object) *module-name*)
+  (setf (valdef-lhs object) (massage-pattern (valdef-lhs object)))
+  (setf (valdef-definitions object)
+	(scope-ast/list (valdef-definitions object) env))
+  object)
+
+
+;;; For a single-fun-def, do the where-decls first, and then walk the
+;;; rhs in an env that includes both the where-decls and the args.
+
+(define-walker-method scope single-fun-def (object env)
+  (setf env (add-pattern-variables (single-fun-def-args object) env))
+  (setf env (add-local-declarations (single-fun-def-where-decls object) env))
+  (setf (single-fun-def-where-decls object)
+	(scope-ast/decl-list (single-fun-def-where-decls object) env))
+  (setf (single-fun-def-args object)
+	(massage-pattern-list (single-fun-def-args object)))
+  (setf (single-fun-def-rhs-list object)
+	(scope-ast/list (single-fun-def-rhs-list object) env))
+  object)
+
+
+;;;===================================================================
+;;; exp-structs
+;;;===================================================================
+
+(define-walker-method scope lambda (object env)
+  (setf env (add-pattern-variables (lambda-pats object) env))
+  (setf (lambda-pats object) (massage-pattern-list (lambda-pats object)))
+  (setf (lambda-body object) (scope-ast-1 (lambda-body object) env))
+  object)
+
+(define-walker-method scope let (object env)
+  (setf env (add-local-declarations (let-decls object) env))
+  (setf (let-decls object) (scope-ast/decl-list (let-decls object) env))
+  (setf (let-body object) (scope-ast-1 (let-body object) env))
+  object)
+
+
+;;; Case alts are treated very much like single-fun-defs.
+
+(define-walker-method scope case (object env)
+  (setf (case-exp object) (scope-ast-1 (case-exp object) env))
+  (dolist (a (case-alts object))
+    (let ((env  (add-pattern-variables (list (alt-pat a)) env)))
+      (setf env (add-local-declarations (alt-where-decls a) env))
+      (setf (alt-where-decls a)
+	    (scope-ast/decl-list (alt-where-decls a) env))
+      (setf (alt-pat a) (massage-pattern (alt-pat a)))
+      (setf (alt-rhs-list a)
+	    (scope-ast/list (alt-rhs-list a) env))))
+  object)
+
+
+(define-walker-method scope var-ref (object env)
+  (when (eq? (var-ref-var object) *undefined-def*)
+	(setf (var-ref-var object)
+	      (lookup-name (var-ref-name object) env)))
+  object)
+
+(define-walker-method scope con-ref (object env)
+  (declare (ignore env))
+  (when (eq? (con-ref-con object) *undefined-def*)
+	(setf (con-ref-con object)
+	      (lookup-toplevel-name (con-ref-name object))))
+  object)
+
+(define-walker-method scope list-comp (object env)
+  (dolist (q (list-comp-quals object))
+    (cond ((is-type? 'qual-generator q)
+	   (setf (qual-generator-exp q)
+		 (scope-ast-1 (qual-generator-exp q) env))
+	   (setf env
+		 (add-pattern-variables (list (qual-generator-pat q)) env))
+	   (setf (qual-generator-pat q)
+		 (massage-pattern (qual-generator-pat q))))
+	  ((is-type? 'qual-filter q)
+	   (setf (qual-filter-exp q)
+		 (scope-ast-1 (qual-filter-exp q) env)))))
+  (setf (list-comp-exp object) (scope-ast-1 (list-comp-exp object) env))
+  object)
+
+(define-walker-method scope pp-exp-list (object env)
+  (massage-pp-exp-list (scope-ast/list (pp-exp-list-exps object) env)))
+
-- 
cgit v1.2.3