;;; walk-ast.scm -- general-purpose walkers for AST structures.
;;;
;;; author :  Sandra & John
;;; date   :  30 Jan 1992
;;;
;;;

;;;=====================================================================
;;; Basic support, macros
;;;=====================================================================


;;; Here is a macro for accessing the walker function for a particular
;;; type.
;;; The walk-type names the walker.
;;; If an accessor argument is provided, it must name a SETF'able function
;;; or macro that takes a type descriptor as an argument.  This is used to
;;; do the lookup of the walker function for the given type.
;;; If no explicit accessor is provided, one will be created.  It will
;;; use a hash table keyed off the type names to store the walker functions.
;;; In either case, the mapping between the walker name and accessor is
;;; stored in the hash table ast-walker-table.

(define ast-walker-table (make-table))

(define-syntax (define-walker walk-type . maybe-accessor)
  (let ((accessor-name  (if (null? maybe-accessor)
			    (symbol-append walk-type '-walker)
			    (car maybe-accessor))))
    (setf (table-entry ast-walker-table walk-type) accessor-name)
	`(begin
	   ,@(if (null? maybe-accessor)
		 (let ((accessor-table (symbol-append '* walk-type '-table*)))
		   `((define ,accessor-table (make-table))
		     (define-syntax (,accessor-name td)
		       (list 'table-entry
			     ',accessor-table
			     (list 'td-name td)))))
		 '())
	   (setf (table-entry ast-walker-table ',walk-type)
		 ',accessor-name)
	   ',walk-type)))

(define-syntax (ast-walker walk-type td)
  (let ((accessor  (table-entry ast-walker-table walk-type)))
    `(,accessor ,td)))


;;; This macro dispatches a walker on an object of type ast-node.

(define-syntax (call-walker walk-type object . args)
  (let ((temp (gensym "OBJ")))
    `(let ((,temp ,object))
       (funcall (or (ast-walker ,walk-type (struct-type-descriptor ,temp))
		    (walker-not-found-error ',walk-type ,temp))
		,temp
		,@args))
    ))

(define (walker-not-found-error walk-type object)
  (error "There is no ~a walker for structure ~A defined."
	 walk-type (td-name (struct-type-descriptor object))))



;;; Define an individual walker for a particular type.  The body should
;;; return either the original object or a replacement for it.

(define-syntax (define-walker-method walk-type type args . body)
  (let ((function-name  (symbol-append walk-type '- type)))
    `(begin
       (define (,function-name ,@args) ,@body)
       (setf (ast-walker ,walk-type (lookup-type-descriptor ',type))
	     (function ,function-name))
       ',function-name)))



;;;=====================================================================
;;; Support for default walker methods
;;;=====================================================================

;;; Two kinds of walkers are supported: a collecting walker, which
;;; walks over a tree collecting some sort of returned result while
;;; not changing the tree itself, and a rewriting walker which maps
;;; ast to ast.

;;; The basic template for a collecting walk is:
;;; (define-walker-method walk-type type (object accum)
;;;   (sf1 (sf2 object ... (sfn accum)))
;;; where sfi = slot function for the ith slot.
;;;
;;; The slot-processor should be the name of a macro that is called with four
;;; arguments:  a slot descriptor, the object type name, a form 
;;; representing the object being traversed, and a form representing the 
;;; accumulated value.
;;; If the slot does not participate in the walk, this last argument should
;;; be returned unchanged as the expansion of the macro.

(define-syntax (define-collecting-walker-methods walk-type types
		 slot-processor)
  `(begin
     ,@(map (lambda (type)
	      (make-collecting-walker-method walk-type type slot-processor))
	    types)))

(define (make-collecting-walker-method walk-type type slot-processor)
  `(define-walker-method ,walk-type ,type (object accum)
     object   ; prevent possible unreferenced variable warning
     ,(make-collecting-walker-method-body
       'accum
       type
       (td-slots (lookup-type-descriptor type))
       slot-processor)))

(define (make-collecting-walker-method-body base type slots slot-processor)
  (if (null? slots)
      base
      `(,slot-processor ,(car slots) ,type object 
		 ,(make-collecting-walker-method-body
		     base type (cdr slots) slot-processor))))



;;; A rewriting walker traverses the ast modifying various subtrees.
;;; The basic template here is:
;;; (define-walker-method walker type (object . args)
;;;   (setf (slot1 object) (walk (slot1 object)))
;;;   (setf (slot2 object) (walk (slot2 object)))
;;;   ...
;;;   object)

;;; The basic macro to generate default walkers is as above except
;;; that the slot-processor macro is called with only 
;;; two arguments, the slot and object type.
;;; The `args' is the actual lambda-list for the methods, and bindings
;;; can be referenced inside the code returned by the macro.
;;; If a slot participates in the walk, the macro should return code
;;; to SETF the slot, as in the template above.  Otherwise, the macro
;;; should just return #f.

(define-syntax (define-modify-walker-methods walk-type types args
		 slot-processor)
  `(begin
     ,@(map (lambda (type)
	      (make-modify-walker-method walk-type type args
					 slot-processor))
	    types)))

(define (make-modify-walker-method walk-type type args slot-processor)
  `(define-walker-method ,walk-type ,type ,args
     ,@(cdr args)  ; prevent possible unreferenced variable warnings
     ,@(map (lambda (slot)
	      `(,slot-processor ,slot ,type))
	    (td-slots (lookup-type-descriptor type)))
     ,(car args)))