Subject: weaver=traversal.scm
From: Gregor Kiczales (gregor@cs.ubc.ca)
Date: Tue Apr 02 2002 - 13:18:36 EST
FYI, here pretty much all the code for adding traversals to ASB.
This has one MAJOR simplification, but it is orthogonal to the adding it to
ASB issue -- it ignores traversal specs, it just visits all values reachable
from the start object. Maybe Mitch has some Scheme code that could fix that?
NOTE also that this has two distinct kinds of JPs, traversal (arrive at object)
and crossing (leave via a field). That may not be the right thing, that's the
substance of the message I sent yesterday.
Who will be in DC?
Gregor
(define traversal-jp? (lambda (x) (jp-kind-test? x 'traversal)))
(define crossing-jp? (lambda (x) (jp-kind-test? x 'crossing)))
(define traverse
(lambda (tname spec object) ;tname means traversal name
;spec is like "from Company to Salary"
;object is a Company
(let ((been-here '())) ;objects we've seen before
;state is where we are in traversal
;it is ignored in this code
(letrec ((arrive
(lambda (state this target)
;(newline) (print 'arrive:) (print target)
(if #t ;!!!(not (memq target been-here))
(begin
(set! been-here (cons target been-here))
(let ((jp (make-jp 'traversal tname tname this target '())))
(ajd-rt-weave (lambda (args) ;args will always be ()
(do-crossings state target))
jp
'()))))))
(do-crossings
(lambda (state this)
;(newline) (print 'do-crossings:) (print this)
(if (object? this)
(let ((fnames (class-name->field-names (object-class-name this)))
(vals (vector->list (object-vals this))))
(for-each (lambda (fname target)
(cross #f this fname target))
fnames
vals)))))
(cross
(lambda (state this fname target)
;(newline) (print 'cross:) (print target)
(let ((jp (make-jp 'crossing tname fname this target '())))
(ajd-rt-weave (lambda (args)
(arrive state this target))
jp
'())))))
(arrive #f #f object)))))
(set! pcd-matches?
(around-wrap pcd-matches?
(lambda (proceed pcd jp succeed fail)
(cond ((traversal-pcd? pcd)
(if (and (traversal-jp? jp)
(eqv? (traversal-pcd-traversal-name pcd)
(jp-name jp)))
(succeed '() '() '())
(fail)))
((crossing-pcd? pcd)
(if (and (crossing-jp? jp)
(eqv? (crossing-pcd-traversal-name pcd)
(jp-within jp))
(eqv? (crossing-pcd-field-name pcd)
(jp-name jp)))
(succeed '() '() '())))
(else (proceed pcd jp succeed fail))))))
This archive was generated by hypermail 2b28 : Tue Apr 02 2002 - 13:16:25 EST