;;; depend/depend.scm     Author: John
 
 ;;; This performs dependency analysis.  All module definitions are gathered
 ;;; into a single nested let/let*.
 
 (define-walker depend ast-td-depend-walker)
 
 ;;; This extracts the declarations out of the top level of the modules and
 ;;; creates a single let defining all values from the modules.
 
 (define (do-dependency-analysis modules)
   (let ((all-decls '()))
     (dolist (mod modules)
       (setf all-decls (append (module-decls mod) all-decls)))
     (analyze-dependency-top
       (**let all-decls (make void)))))
 
 
 (define *depend-fn-table* (make-table))
 
 (define-syntax (var-depend-fn var)
   `(table-entry *depend-fn-table* ,var))
 
 (define (analyze-dependency-top x)
   (dynamic-let ((*depend-fn-table*  (make-table)))
     (analyze-dependency x)))
 
 
 ;;; This is the entry point to dependency analysis for an expression or decl
 
 (define (analyze-dependency x)
   (call-walker depend x))
 
 (define (analyze-dependency/list l)
   (dolist (x l)
     (analyze-dependency x)))
 
 ;;; This makes default walkers for dependency analysis.  Expressions are
 ;;; walked into; declaration lists must be sorted.
 
 (define-local-syntax (make-depend-code slot type)
   (let ((stype  (sd-type slot))
         (sname  (sd-name slot))
 	(depend-exp-types '(exp alt qual single-fun-def guarded-rhs)))
     (cond ((and (symbol? stype)
 		(memq stype depend-exp-types))
 	   `(analyze-dependency (struct-slot ',type ',sname object)))
           ((and (pair? stype)
                 (eq? (car stype) 'list)
                 (symbol? (cadr stype))
                 (memq (cadr stype) depend-exp-types)
 	   `(analyze-dependency/list
 		(struct-slot ',type ',sname object))))
           ((equal? stype '(list decl))
 	   `(setf (struct-slot ',type ',sname object)
 		  (restructure-decl-list (struct-slot ',type ',sname object))))
           (else
 ;           (format '#t "Depend: skipping slot ~A in ~A~%"
 ;                  (sd-name slot)
 ;                  type)
            '#f))))
 
 (define-modify-walker-methods depend
   (lambda let if case alt exp-sign app con-ref
    integer-const float-const char-const string-const
    list-exp sequence sequence-then sequence-to sequence-then-to
    list-comp section-l section-r qual-generator qual-filter omitted-guard
    con-number sel is-constructor cast void
    single-fun-def guarded-rhs
    case-block return-from and-exp
    )
   (object)
   make-depend-code)
 
 ;;; This sorts a list of decls.  Recursive groups are placed in
 ;;; special structures: recursive-decl-group
 
 (define (restructure-decl-list decls)
   (let ((stack '())
 	(now 0)
 	(sorted-decls '())
 	(edge-fn '()))
    (letrec ((visit (lambda (k)
 		     (let ((minval 0)
 			   (recursive? '#f)
 			   (old-edge-fn edge-fn))
 		       (incf now)
 ;		       (format '#t "Visiting ~A: id = ~A~%" (valdef-lhs k) now)
 		       (setf (valdef-depend-val k) now)
 		       (setf minval now)
 		       (push k stack)
 		       (setf edge-fn
 			     (lambda (tv)
 ;			       (format '#t "Edge ~A -> ~A~%" (valdef-lhs k)
 ;				                             (valdef-lhs tv))
 			       (let ((val (valdef-depend-val tv)))
                                 (cond ((eq? tv k)
 				       (setf recursive? '#t))
 				      ((eqv? val 0)
 				       (setf minval (min minval
 							 (funcall visit tv))))
 				      (else
 				       (setf minval (min minval val))))
 ;				(format '#t "Min for ~A is ~A~%"
 ;					(valdef-lhs k) minval)
 			       )))
 		       (analyze-dependency/list (valdef-definitions k))
 		       (setf edge-fn old-edge-fn)
 		       (when (eqv? minval (valdef-depend-val k))
 			 (let ((defs '()))
 			   (do ((quit? '#f)) (quit?)
 			     (push (car stack) defs)
 			     (setf (valdef-depend-val (car stack)) 100000)
 			     (setf quit? (eq? (car stack) k))
 			     (setf stack (cdr stack)))
 ;			   (format '#t "Popping stack: ~A~%"
 ;				   (map (lambda (x) (valdef-lhs x)) defs))
 			   (if (and (null? (cdr defs))
 				    (not recursive?))
 			       (push k sorted-decls)
 			       (push (make recursive-decl-group (decls defs))
 				     sorted-decls))))
 		       minval))))
     ;; for now assume all decl lists have only valdefs
     (dolist (d decls)
       (let ((decl d))  ; to force new binding for each closure
 	(setf (valdef-depend-val decl) 0)
 	(dolist (var (collect-pattern-vars (valdef-lhs decl)))
 	  (setf (var-depend-fn (var-ref-var var))
 		(lambda () (funcall edge-fn decl))))))
     (dolist (decl decls)
       (when (eqv? (valdef-depend-val decl) 0)
 	(funcall visit decl)))
     (dolist (decl decls)
       (dolist (var (collect-pattern-vars (valdef-lhs decl)))
 	(setf (var-depend-fn (var-ref-var var)) '#f)))
     (nreverse sorted-decls))))
 
 ;;; This is the only non-default walker needed.  When a reference to a
 ;;; variable is encountered, the sort algorithm above is notified.
 
 (define-walker-method depend var-ref (object)
   (let ((fn (var-depend-fn (var-ref-var object))))
     (when (not (eq? fn '#f))
        (funcall fn))))
 
 (define-walker-method depend overloaded-var-ref (object)
   (let ((fn (var-depend-fn (overloaded-var-ref-var object))))
     (when (not (eq? fn '#f))
        (funcall fn))))