diff options
| -rw-r--r-- | eval.c | 7 | ||||
| -rw-r--r-- | share/txr/stdlib/place.tl | 18 |
2 files changed, 21 insertions, 4 deletions
@@ -220,6 +220,12 @@ val lookup_origin(val form) return gethash(origin_hash, form); } +static val set_origin(val form, val origin) +{ + (void) sethash(origin_hash, form, origin); + return form; +} + void error_trace(val exsym, val exvals, val out_stream, val prefix) { val last = last_form_evaled; @@ -5071,6 +5077,7 @@ void eval_init(void) reg_fun(intern(lit("source-loc"), user_package), func_n1(source_loc)); reg_fun(intern(lit("source-loc-str"), user_package), func_n2o(source_loc_str, 1)); reg_fun(intern(lit("macro-ancestor"), user_package), func_n1(lookup_origin)); + reg_fun(intern(lit("set-macro-ancestor"), system_package), func_n2(set_origin)); reg_fun(intern(lit("rlcp"), user_package), func_n2(rlcp)); eval_error_s = intern(lit("eval-error"), user_package); 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) |