;;; strictness.scm -- strictness analyzer
;;;
;;; author :  Sandra Loosemore
;;; date   :  28 May 1992
;;;
;;; The algorithm used here follows Consel, "Fast Strictness Analysis
;;; Via Symbolic Fixpoint Interation".
;;;
;;; The basic idea is to do a traversal of the flic structure, building
;;; a boolean term that represents the strictness of each subexpression.
;;; The boolean terms are composed of ands & ors of the argument variables
;;; to each function.  After traversing the body of the function, we can
;;; determine which argument variables are strict by examining the 
;;; corresponding term, and then we can update the strictness attribute
;;; of the var that names the function.
;;;
;;; Another traversal needs to be done to attach strictness properties
;;; to locally bound variables.  


;;; Here's the main entry point.

(define (strictness-analysis-top big-let)
  (fun-strictness-walk big-let)
  (var-strictness-walk big-let '() '())
  ;; *** This probably belongs somewhere else?
  (do-box-analysis big-let '() '() '#t)
  big-let)


;;;======================================================================
;;; Function strictness analyzer code walk
;;;======================================================================

;;; This actually involves two code walkers.  The first merely traverses
;;; structure and identifies function definitions.  The second traverses
;;; the definitions of the functions to compute their strictness.


;;; Fun-strictness-walk is the walker to find function definitions.
;;; This is trivial for everything other than flic-let.

(define-flic-walker fun-strictness-walk (object))

(define-fun-strictness-walk flic-lambda (object)
  (fun-strictness-walk (flic-lambda-body object)))

(define-fun-strictness-walk flic-let (object)
  (if (flic-let-recursive? object)
      (fun-strictness-walk-letrec object)
      (fun-strictness-walk-let* object))
  (dolist (v (flic-let-bindings object))
    (fun-strictness-walk (var-value v)))
  (fun-strictness-walk (flic-let-body object)))

(define-fun-strictness-walk flic-app (object)
  (fun-strictness-walk (flic-app-fn object))
  (for-each (function fun-strictness-walk) (flic-app-args object)))

(define-fun-strictness-walk flic-ref (object)
  (declare (ignore object))
  '#f)

(define-fun-strictness-walk flic-pack (object)
  (declare (ignore object))
  '#f)

(define-fun-strictness-walk flic-const (object)
  (declare (ignore object))
  '#f)

(define-fun-strictness-walk flic-case-block (object)
  (for-each (function fun-strictness-walk) (flic-case-block-exps object)))

(define-fun-strictness-walk flic-return-from (object)
  (fun-strictness-walk (flic-return-from-exp object)))

(define-fun-strictness-walk flic-and (object)
  (for-each (function fun-strictness-walk) (flic-and-exps object)))

(define-fun-strictness-walk flic-if (object)
  (fun-strictness-walk (flic-if-test-exp object))
  (fun-strictness-walk (flic-if-then-exp object))
  (fun-strictness-walk (flic-if-else-exp object)))

(define-fun-strictness-walk flic-sel (object)
  (fun-strictness-walk (flic-sel-exp object)))

(define-fun-strictness-walk flic-is-constructor (object)
  (fun-strictness-walk (flic-is-constructor-exp object)))

(define-fun-strictness-walk flic-con-number (object)
  (fun-strictness-walk (flic-con-number-exp object)))

(define-fun-strictness-walk flic-void (object)
  (declare (ignore object))
  '#f)



;;; Here is the magic for let bindings of function definitions.
;;; Sequential bindings are easy.  For recursive bindings, we must 
;;; keep track of mutually recursive functions.
;;; If a function binding has a strictness annotation attached,
;;; do not mess with it further.

(define (fun-strictness-walk-let* object)
  (dolist (var (flic-let-bindings object))
    (let ((val  (var-value var)))
      (when (is-type? 'flic-lambda val)
	(if (var-strictness var)
	    (mark-argument-strictness
	      (var-strictness var) (flic-lambda-vars val))
	    (compute-function-strictness var val '())))
      )))

(define (fun-strictness-walk-letrec object)
  (let ((stack   '()))
    (dolist (var (flic-let-bindings object))
      (let ((val  (var-value var)))
	(if (and (is-type? 'flic-lambda val) (not (var-strictness var)))
	    (setf stack (add-recursive-function-1 var (init-var-env) stack)))))
    (dolist (var (flic-let-bindings object))
      (let ((val  (var-value var)))
	(when (is-type? 'flic-lambda val)
	  (if (var-strictness var)
	      (mark-argument-strictness
	        (var-strictness var) (flic-lambda-vars val))
	      (compute-function-strictness var val stack)))
	))))

(define (compute-function-strictness var val stack)
  (let* ((vars  (flic-lambda-vars val))
	 (env   (add-var-binding-n vars (map (function list) vars)
				   (init-var-env)))
	 (term  (compute-strictness-walk (flic-lambda-body val) env stack)))
    (when (eq? term '#t)
      (signal-infinite-loop-function var)
      (setf (flic-lambda-body val)
	    (make-infinite-loop-error
	      (format '#f "Function ~s has an infinite loop." var))))
    (setf (var-strictness var) (munge-strictness-terms term vars))))


(define (signal-infinite-loop-function var)
  (recoverable-error 'infinite-loop-function
    "Function ~s has an infinite loop."
    var))

(define (make-infinite-loop-error msg)
  (make-flic-app
    (make-flic-ref (core-symbol "error"))
    (list (make-flic-const msg))
    '#t))

  
;;; compute-strictness-walk is the traversal to compute strictness
;;; terms.
;;; The purpose of the env is to map locally bound variables onto 
;;; strictness terms which are expressed as lists of argument variables
;;; to the function being analyzed.
;;; The purpose of the stack is to keep track of recursive function
;;; walks and recognize when we've reached a fixed point.

(define-flic-walker compute-strictness-walk (object env stack))


;;; Making a function never forces anything.

(define-compute-strictness-walk flic-lambda (object env stack)
  (declare (ignore object env stack))
  '#f)


;;; For let, add bindings to environment and get strictness of body.

(define-compute-strictness-walk flic-let (object env stack)
  (let ((bindings    (flic-let-bindings object))
	(body        (flic-let-body object))
	(recursive?  (flic-let-recursive? object)))
    (if recursive?
	;; Must add stuff to env and stack before traversing anything.
	(begin
	  (dolist (var bindings)
	    (setf env (add-var-binding-1 var '#f env)))
	  (dolist (var bindings)
	    (let ((val  (var-value var)))
	      (when (is-type? 'flic-lambda val)
		(setf stack (add-recursive-function-1 var env stack)))))
	  (dolist (var bindings)
	    (let ((val  (var-value var)))
	      (set-var-env var env (compute-strictness-walk val env stack)))))
	;; Otherwise just do things sequentially.
	;; Note that even though there is no possibility of recursion
	;; here, we must add stuff to the stack anyway so that we can
	;; walk calls in the correct env.
	(dolist (var bindings)
	  (let ((val  (var-value var)))
	    (when (is-type? 'flic-lambda val)
	      (setf stack (add-recursive-function-1 var env stack)))
	    (setf env
		  (add-var-binding-1
		    var (compute-strictness-walk val env stack) env)))))
    (compute-strictness-walk body env stack)))


;;; Treat explicit, saturated calls to named functions specially.

(define-compute-strictness-walk flic-app (object env stack)
  (let ((fn         (flic-app-fn object))
	(args       (flic-app-args object))
	(saturated? (flic-app-saturated? object)))
    (cond ((and (is-type? 'flic-ref fn) saturated?)
	   ;; Special handling for named functions.
	   (compute-application-strictness
	     (flic-ref-var fn)
	     args env stack))
	  ((and (is-type? 'flic-pack fn) saturated?)
	   ;; Similarly for constructor applications, but we always
	   ;; know which arguments are strict in advance.
	   (compute-application-strictness-aux
	      (con-slot-strict? (flic-pack-con fn))
	      args env stack))
	  (else
	   ;; Otherwise, we know that the function expression is going to
	   ;; be forced, but all of its arguments are lazy.  So ignore the
	   ;; arguments in computing the strictness of the whole expression.
	   (compute-strictness-walk fn env stack)))))


(define (compute-application-strictness var args env stack)
  (let* ((strictness          (var-strictness var))
	 (info                '#f)
	 (arg-strictness-list '#f))
    (cond ((eq? var (core-symbol "error"))
	   ;; This expression will return bottom no matter what.
	   'error)
	  (strictness
	   ;; We've already completed the walk for this function and
	   ;; determined which of its arguments are strict.
	   ;; The strictness expression for the application is the
	   ;; OR of the strictness of its non-lazy arguments.
	   (compute-application-strictness-aux strictness args env stack))
	  ((get-recursive-function-trace
	     (setf arg-strictness-list
		   (map (lambda (a) (compute-strictness-walk a env stack))
			args))
	     (setf info (get-recursive-function var stack)))
	   ;; We're already tracing this call.  Return true to
	   ;; terminate the fixpoint iteration.
	   '#t)
	  (else
	   ;; Otherwise, begin a new trace instance.
	   ;; Add stuff to the saved var-env to map references to
	   ;; the argument variables to the strictness terms for
	   ;; the actual arguments at this call site.
	   ;; References to closed-over variables within the function
	   ;; use the strictness values that were stored in the env
	   ;; at the point of function definition.
	   (let* ((env      (get-recursive-function-env info))
		  (lambda   (var-value var))
		  (body     (flic-lambda-body lambda))
		  (vars     (flic-lambda-vars lambda))
		  (result   '#f))
	     (push-recursive-function-trace arg-strictness-list info)
	     (setf result
		   (compute-strictness-walk
		     body
		     (add-var-binding-n vars arg-strictness-list env)
		     stack))
	     (pop-recursive-function-trace info)
	     result))
	  )))


(define (compute-application-strictness-aux strictness args env stack)
  (make-or-term
    (map (lambda (strict? arg)
	   (if strict? (compute-strictness-walk arg env stack) '#f))
	 strictness args)))


;;; For a reference, look up the term associated with the variable in env.
;;; If not present in the environment, ignore it; the binding was established
;;; outside the scope of the function being analyzed.

(define-compute-strictness-walk flic-ref (object env stack)
  (declare (ignore stack))
  (get-var-env (flic-ref-var object) env))
	

;;; References to constants or constructors never fail.

(define-compute-strictness-walk flic-const (object env stack)
  (declare (ignore object env stack))
  '#f)

(define-compute-strictness-walk flic-pack (object env stack)
  (declare (ignore object env stack))
  '#f)


;;; The first clause of a case-block is the only one that is always
;;; executed, so it is the only one that affects the strictness of
;;; the overall expression.

(define-compute-strictness-walk flic-case-block (object env stack)
  (compute-strictness-walk (car (flic-case-block-exps object)) env stack))


;;; Return-from fails if its subexpression fails.

(define-compute-strictness-walk flic-return-from (object env stack)
  (compute-strictness-walk (flic-return-from-exp object) env stack))


;;; For and, the first subexpression is the only one that is always
;;; executed, so it is the only one that affects the strictness of
;;; the overall expression.

(define-compute-strictness-walk flic-and (object env stack)
  (compute-strictness-walk (car (flic-and-exps object)) env stack))


;;; The strictness of an IF is the strictness of the test OR'ed
;;; with the AND of the strictness of its branches.

(define-compute-strictness-walk flic-if (object env stack)
  (make-or-term-2
    (compute-strictness-walk (flic-if-test-exp object) env stack)
    (make-and-term-2
      (compute-strictness-walk (flic-if-then-exp object) env stack)
      (compute-strictness-walk (flic-if-else-exp object) env stack))))


;;; Selecting a component of a data structure causes it to be forced,
;;; so propagate the strictness of the subexpression upwards.

(define-compute-strictness-walk flic-sel (object env stack)
  (compute-strictness-walk (flic-sel-exp object) env stack))


;;; Is-constructor and con-number force their subexpressions.

(define-compute-strictness-walk flic-is-constructor (object env stack)
  (compute-strictness-walk (flic-is-constructor-exp object) env stack))

(define-compute-strictness-walk flic-con-number (object env stack)
  (compute-strictness-walk (flic-con-number-exp object) env stack))

(define-compute-strictness-walk flic-void (object env stack)
  (declare (ignore object env stack))
  '#f)



;;;======================================================================
;;; Utilities for managing the env
;;;======================================================================

;;; The env is just an a-list.

(define (init-var-env)
  '())

(define (add-var-binding-1 var binding env)
  (cons (cons var binding) env))

(define (add-var-binding-n vars bindings env)
  (if (null? vars)
      env
      (add-var-binding-n (cdr vars) (cdr bindings)
			 (cons (cons (car vars) (car bindings)) env))))

(define (get-var-env var env)
  (let ((stuff  (assq var env)))
    (if stuff
	(cdr stuff)
	'#f)))

(define (set-var-env var env new-value)
  (let ((stuff  (assq var env)))
    (if stuff
	(setf (cdr stuff) new-value)
	(error "Can't find binding for ~s in environment." var))))
  


;;;======================================================================
;;; Utilities for managing the stack
;;;======================================================================

;;; For now, the stack is just an a-list too.
;;; Some sort of hashing scheme could also be used instead of a linear
;;; search, but if the iteration depth for the fixpoint analysis is
;;; small, it's probably not worth the trouble.

(define (add-recursive-function-1 var env stack)
  (cons (list var env '()) stack))

(define (get-recursive-function var stack)
  (or (assq var stack)
      (error "Can't find entry for ~s in stack." var)))

(define (get-recursive-function-env entry)
  (cadr entry))

(define (push-recursive-function-trace new-args entry)
  (push new-args (caddr entry)))

(define (pop-recursive-function-trace entry)
  (pop (caddr entry)))

(define (get-recursive-function-trace args entry)
  (get-recursive-function-trace-aux args (caddr entry)))

(define (get-recursive-function-trace-aux args list)
  (cond ((null? list)
	 '#f)
	((every (function term=) args (car list))
	 '#t)
	(else
	 (get-recursive-function-trace-aux args (cdr list)))))


;;;======================================================================
;;; Utilities for boolean terms
;;;======================================================================


;;; A term is either #t, #f, the symbol 'error, or a list of variables 
;;; (which are implicitly or'ed together).
;;; #t and 'error are treated identically, except that #t indicates
;;; failure because of infinite recursion and 'error indicates failure
;;; due to a call to the error function.
;;; In general, AND terms add nothing to the result, so to reduce
;;; needless computation we generally reduce (and a b) to #f.

;;; Make an OR term.  First look for some obvious special cases as an
;;; efficiency hack, otherwise fall through to more general code.

(define (make-or-term terms)
  (cond ((null? terms)
	 '#f)
	((null? (cdr terms))
	 (car terms))
	((eq? (car terms) '#t)
	 '#t)
	((eq? (car terms) 'error)
	 'error)
	((eq? (car terms) '#f)
	 (make-or-term (cdr terms)))
	(else
	 (make-or-term-2 (car terms) (make-or-term (cdr terms))))))

(define (make-or-term-2 term1 term2)
  (cond ((eq? term2 '#t)
	 '#t)
	((eq? term2 'error)
	 'error)
	((eq? term2 '#f)
	 term1)
	((eq? term1 '#t)
	 '#t)
	((eq? term1 'error)
	 'error)
	((eq? term1 '#f)
	 term2)
	;; At this point we know both terms are variable lists.
	((implies? term2 term1)
	 term2)
	((implies? term1 term2)
	 term1)
	(else
	 (merge-list-terms term1 term2))))


;;;  Merge the two lists, throwing out duplicate variables.

(define (merge-list-terms list1 list2)
  (cond ((null? list1)
	 list2)
	((null? list2)
	 list1)
	((eq? (car list1) (car list2))
	 (cons (car list1) (merge-list-terms (cdr list1) (cdr list2))))
	((var< (car list1) (car list2))
	 (cons (car list1) (merge-list-terms (cdr list1) list2)))
	(else
	 (cons (car list2) (merge-list-terms list1 (cdr list2))))))


;;; Helper function: does term1 imply term2?
;;; True if every subterm of term2 is also included in term1.

(define (implies? term1 term2)
  (every (lambda (v2) (memq v2 term1)) term2))


;;; Make an AND term.  Because we don't want to build up arbitrarily
;;; complex AND expressions, basically just compute an OR list that 
;;; represents the intersection of the subterms.

(define (make-and-term terms)
  (cond ((null? terms)
	 '#f)
	((null? (cdr terms))
	 (car terms))
	((eq? (car terms) '#t)
	 (make-and-term (cdr terms)))
	((eq? (car terms) 'error)
	 (make-and-term (cdr terms)))
	((eq? (car terms) '#f)
	 '#f)
	(else
	 (make-and-term-2 (car terms) (make-and-term (cdr terms))))))

(define (make-and-term-2 term1 term2)
  (cond ((eq? term2 '#t)
	 term1)
	((eq? term2 'error)
	 term1)
	((eq? term2 '#f)
	 '#f)
	((eq? term1 '#t)
	 term2)
	((eq? term1 'error)
	 term2)
	((eq? term1 '#f)
	 '#f)
	;; At this point we know both terms are variable lists.
	((implies? term2 term1)
	 term1)
	((implies? term1 term2)
	 term2)
	(else
	 (let ((result  '()))
	   (dolist (v term1)
	     (if (memq v term2)
		 (push v result)))
	   (if (null? result)
	       '#f
	       (nreverse result))))
	))


;;; Subterms of an and/or term are always sorted, so that to compare
;;; two terms we can just compare subterms componentwise.

(define (term= term1 term2)
  (or (eq? term1 term2)
      (and (pair? term1)
	   (pair? term2)
	   (eq? (car term1) (car term2))
	   (term= (cdr term1) (cdr term2)))))


;;; Variables within an OR-list are sorted alphabetically by names.

(define (var< var1 var2)
  (string<? (symbol->string (def-name var1))
	    (symbol->string (def-name var2))))


;;; Determine which of the vars are present in the term.

(define (munge-strictness-terms term vars)
  (map (lambda (v)
	 (setf (var-strict? v)
	       (cond ((var-force-strict? v)
		      '#t)
		     ((eq? term '#t)
		      '#t)
		     ((eq? term 'error)
		      '#t)
		     ((eq? term '#f)
		      '#f)
		     ((memq v term)
		      '#t)
		     (else
		      '#f))))
       vars))

(define (mark-argument-strictness strictness vars)
  (map (lambda (s v) (setf (var-strict? v) s)) strictness vars))



;;;======================================================================
;;; Variable strictness propagation code walk
;;;======================================================================

;;; Walk the code, marking any vars found in strict contexts as strict.
;;; Locally bound variables are consed onto the varlist.  This is
;;; used to determine which variables can be marked as strict when they
;;; appear in strict contexts.
;;; When walking something that does not appear in a strict context
;;; or that is not always evaluated, reinitialize varlist to the empty
;;; list.
;;; The stack is used to keep track of variables that have not been
;;; initialized yet, so that we can detect some kinds of infinite loops.
;;; When walking something that is not always evaluated, reset this to 
;;; the empty list.

(define-flic-walker var-strictness-walk (object varlist stack))



;;; Since the body of the lambda might not be evaluated, reset
;;; both varlist and stack.

(define-var-strictness-walk flic-lambda (object varlist stack)
  (declare (ignore varlist stack))
  (var-strictness-walk (flic-lambda-body object) '() '()))


;;; The basic idea for let is to find the variables that are strict in 
;;; the body first, and propagate that information backwards to the 
;;; binding initializers.

(define-var-strictness-walk flic-let (object varlist stack)
  (let ((bindings  (flic-let-bindings object)))
    (var-strictness-walk-let-aux
      bindings
      (flic-let-body object)
      (append bindings varlist)
      (append bindings stack)
      (flic-let-recursive? object))))

(define (var-strictness-walk-let-aux bindings body varlist stack recursive?)
  (if (null? bindings)
      (var-strictness-walk body varlist stack)
      (begin
	(var-strictness-walk-let-aux
	  (cdr bindings) body varlist (cdr stack) recursive?)
	(let* ((var  (car bindings))
	       (val  (var-value var)))
	  (cond ((var-strict? var)
		 ;; Recursive variables have to be set back to unstrict
		 ;; because the value form might contain forward references.
		 ;; The box analyzer will set them to strict again if the
		 ;; value forms are safe.
		 (when recursive? (setf (var-strict? var) '#f))
		 ;; Detect x = 1 + x circularities here
		 (var-strictness-walk val varlist stack))
		((flic-exp-strict-result? val)
		 ;; The val is going to be wrapped in a delay.
		 (var-strictness-walk val '() '()))
		(else
		 ;; Watch out for x = x and x = cdr x circularities.
		 ;; *** I am still a little confused about this.  It
		 ;; *** seems like the stack should be passed through
		 ;; *** when walking already-boxed values that appear as
                 ;; *** non-strict function arguments as well, but doing
		 ;; *** so generates some apparently bogus complaints
		 ;; *** about infinite loops.  So maybe doing it here
		 ;; *** is incorrect too, and we just haven't run across
		 ;; *** a test case that triggers it???
		 (var-strictness-walk val '() stack))
		)))))


(define (flic-exp-strict-result? val)
  (cond ((is-type? 'flic-ref val)
	 (var-strict? (flic-ref-var val)))
	((is-type? 'flic-sel val)
	 (list-ref (con-slot-strict? (flic-sel-con val)) (flic-sel-i val)))
	(else
	 '#t)))

(define-var-strictness-walk flic-app (object varlist stack)
  (let ((fn           (flic-app-fn object))
	(args         (flic-app-args object))
	(saturated?   (flic-app-saturated? object)))
    (cond ((and saturated? (is-type? 'flic-ref fn))
	   ;; Strictness of function should be stored on var
	   (do-var-strictness-flic-app-aux
	     (var-strictness (flic-ref-var fn))
	     fn args varlist stack))
	  ((and saturated? (is-type? 'flic-pack fn))
	   ;; Strictness of constructor should be stored on con
	   (do-var-strictness-flic-app-aux
	     (con-slot-strict? (flic-pack-con fn))
	     fn args varlist stack))
	  (else
	   ;; All arguments are non-strict
	   (var-strictness-walk fn varlist stack)
	   (dolist (a args)
	     (var-strictness-walk a '() '()))))))

(define (do-var-strictness-flic-app-aux strictness fn args varlist stack)
  (when (not strictness)
    (error "Can't find strictness for function ~s." fn))
  (dolist (a args)
    (if (pop strictness)
	(var-strictness-walk a varlist stack)
	(var-strictness-walk a '() '()))))


(define-var-strictness-walk flic-ref (object varlist stack)
  (let ((var  (flic-ref-var object)))
    (cond ((memq var stack)
	   ;; Circular variable definition detected.
	   (signal-infinite-loop-variable var)
	   (setf (var-value var)
		 (make-infinite-loop-error
		   (format '#f "Variable ~s has an infinite loop." var))))
	  ((memq var varlist)
	   (setf (var-strict? var) '#t))
	  (else
	   '#f))))

(define (signal-infinite-loop-variable var)
  (recoverable-error 'infinite-loop-variable
    "Variable ~s has an infinite loop."
    var))

(define-var-strictness-walk flic-const (object varlist stack)
  (declare (ignore object varlist stack))
  '#f)

(define-var-strictness-walk flic-pack (object varlist stack)
  (declare (ignore object varlist stack))
  '#f)

(define-var-strictness-walk flic-case-block (object varlist stack)
  (var-strictness-walk (car (flic-case-block-exps object)) varlist stack)
  (dolist (exp (cdr (flic-case-block-exps object)))
    (var-strictness-walk exp '() '())))

(define-var-strictness-walk flic-return-from (object varlist stack)
  (var-strictness-walk (flic-return-from-exp object) varlist stack))

(define-var-strictness-walk flic-and (object varlist stack)
  (var-strictness-walk (car (flic-and-exps object)) varlist stack)
  (dolist (exp (cdr (flic-and-exps object)))
    (var-strictness-walk exp '() '())))

(define-var-strictness-walk flic-if (object varlist stack)
  (var-strictness-walk (flic-if-test-exp object) varlist stack)
  (var-strictness-walk (flic-if-then-exp object) '() '())
  (var-strictness-walk (flic-if-else-exp object) '() '()))

(define-var-strictness-walk flic-sel (object varlist stack)
  (var-strictness-walk (flic-sel-exp object) varlist stack))

(define-var-strictness-walk flic-is-constructor (object varlist stack)
  (var-strictness-walk (flic-is-constructor-exp object) varlist stack))

(define-var-strictness-walk flic-con-number (object varlist stack)
  (var-strictness-walk (flic-con-number-exp object) varlist stack))

(define-var-strictness-walk flic-void (object varlist stack)
  (declare (ignore object varlist stack))
  '#f)



;;;======================================================================
;;; Printer support
;;;======================================================================

(define (strictness-analysis-printer big-let)
  (print-strictness big-let 0))

(define (print-strictness-list list depth)
  (dolist (o list)
    (print-strictness o depth)))

(define (print-strictness-indent depth)
  (dotimes (i (* 2 depth))
    (declare (ignorable i))
    (write-char #\space)))

(define (strictness-string bool)
  (if bool "#t" "#f"))

(define-flic-walker print-strictness (object depth))

(define-print-strictness flic-lambda (object depth)
  (print-strictness-indent depth)
  (format '#t "In anonymous function:~%")
  (print-strictness (flic-lambda-body object) (1+ depth)))

(define-print-strictness flic-let (object depth)
  (dolist (var (flic-let-bindings object))
    (let ((val  (var-value var)))
      (if (is-type? 'flic-lambda val)
	  (begin
	    (print-strictness-indent depth)
	    (format '#t "Function ~s has argument strictness ~a.~%"
		    var
		    (map (function strictness-string) (var-strictness var)))
	    (print-strictness (flic-lambda-body val) (1+ depth)))
	  (begin
	    (print-strictness-indent depth)
	    (format '#t "Variable ~s has strictness ~a.~%"
		    var
		    (strictness-string (var-strict? var)))
	    (print-strictness val depth)))))
  (print-strictness (flic-let-body object) depth))

(define-print-strictness flic-app (object depth)
  (print-strictness (flic-app-fn object) depth)
  (print-strictness-list (flic-app-args object) depth))

(define-print-strictness flic-ref (object depth)
  (declare (ignore object depth))
  '#f)

(define-print-strictness flic-const (object depth)
  (declare (ignore object depth))
  '#f)

(define-print-strictness flic-pack (object depth)
  (declare (ignore object depth))
  '#f)

(define-print-strictness flic-case-block (object depth)
  (print-strictness-list (flic-case-block-exps object) depth))

(define-print-strictness flic-return-from (object depth)
  (print-strictness (flic-return-from-exp object) depth))

(define-print-strictness flic-and (object depth)
  (print-strictness-list (flic-and-exps object) depth))

(define-print-strictness flic-if (object depth)
  (print-strictness (flic-if-test-exp object) depth)
  (print-strictness (flic-if-then-exp object) depth)
  (print-strictness (flic-if-else-exp object) depth))

(define-print-strictness flic-sel (object depth)
  (print-strictness (flic-sel-exp object) depth))

(define-print-strictness flic-is-constructor (object depth)
  (print-strictness (flic-is-constructor-exp object) depth))

(define-print-strictness flic-con-number (object depth)
  (print-strictness (flic-con-number-exp object) depth))

(define-print-strictness flic-void (object depth)
  (declare (ignore object depth))
  '#f)