path: root/prec/scope.scm

;;; 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)))