From 4e987026148fe65c323afbc93cd560c07bf06b3f Mon Sep 17 00:00:00 2001 From: Yale AI Dept Date: Wed, 14 Jul 1993 13:08:00 -0500 Subject: Import to github. --- util/walk-ast.scm | 156 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 156 insertions(+) create mode 100644 util/walk-ast.scm (limited to 'util/walk-ast.scm') 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))) -- cgit v1.2.3