diff options
| author | Kaz Kylheku <kaz@kylheku.com> | 2015-12-17 06:16:02 -0800 |
|---|---|---|
| committer | Kaz Kylheku <kaz@kylheku.com> | 2015-12-17 15:53:05 -0800 |
| commit | 169c03e5ba18ed980683f38ca9d8451987cc0610 (patch) | |
| tree | 7023715728b56ab7a62fa3aec41d634ba588c646 /share | |
| parent | f8c5f7d4950a6fb660c533625ef5004f998432b1 (diff) | |
| download | txr-169c03e5ba18ed980683f38ca9d8451987cc0610.tar.gz txr-169c03e5ba18ed980683f38ca9d8451987cc0610.tar.bz2 txr-169c03e5ba18ed980683f38ca9d8451987cc0610.zip | |
Set macro ancestry info in place expansions.
* eval.c (set_origin): New static function.
(eval_init): Register set_origin as sys:set-macro-ancestor.
* share/txr/stdlib/place.tl (sys:pl-expand): Set macro
ancestry when expanding a place macro.
(sys:cp-origin): New function.
(call-update-expander, call-clobber-expander,
call-delete-expander): Use sys:cp-origin to walk through
expanded code and attach the place form as the macro
ancestor of all the getter, setter or deleter calls,
effectively to say that those calls are expansions of
the place, which is approximately the case.
Diffstat (limited to 'share')
| -rw-r--r-- | share/txr/stdlib/place.tl | 18 |
1 files changed, 14 insertions, 4 deletions
diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl index 02a5c653..b22e4a16 100644 --- a/share/txr/stdlib/place.tl +++ b/share/txr/stdlib/place.tl @@ -132,7 +132,9 @@ (let ((pm-expander [*place-macro* (if (consp unex-place) (car unex-place))])) (when pm-expander - (sys:setq place [pm-expander unex-place]))) + (sys:setq place (sys:set-macro-ancestor + [pm-expander unex-place] + unex-place)))) (sys:setq place (macroexpand place env)) (when (or (eq place unex-place) (null place) @@ -143,20 +145,28 @@ (return place)) (sys:setq unex-place place)))) + (defun sys:cp-origin (to-tree from-form . syms) + (tree-case to-tree + ((a . d) (when (memq a syms) + (sys:set-macro-ancestor to-tree from-form)) + (sys:cp-origin a from-form . syms) + (sys:cp-origin d from-form . syms))) + to-tree) + (defun call-update-expander (getter setter unex-place env body) (let* ((place (sys:pl-expand unex-place env)) (expander (get-update-expander place))) - [expander getter setter place body])) + (sys:cp-origin [expander getter setter place body] place setter getter))) (defun call-clobber-expander (ssetter unex-place env body) (let* ((place (sys:pl-expand unex-place env)) (expander (get-clobber-expander place))) - [expander ssetter place body])) + (sys:cp-origin [expander ssetter place body] place ssetter))) (defun call-delete-expander (deleter unex-place env body) (let* ((place (sys:pl-expand unex-place env)) (expander (get-delete-expander place))) - [expander deleter place body]))) + (sys:cp-origin [expander deleter place body] place deleter)))) (defmacro with-update-expander ((getter setter) unex-place env body) ^(with-gensyms (,getter ,setter) |