1 files changed, 156 insertions, 0 deletions
diff --git a/util/walk-ast.scm b/util/walk-ast.scm
new file mode 100644
index 0000000..aecffc6
--- /dev/null
+++ b/util/walk-ast.scm
@@ -0,0 +1,156 @@
+;;; 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)))