* lisplib.c (place_set_entries): Add *place-macro* and

define-place-macro to list of names.

* share/txr/stdlib/place.tl (*place-macro*): New global hash.
(sys:tigger-load, sys:pl-expand): New functions.
(call-update-expander, call-clobber-expander, call-delete-expander):
Recognize and expand place macros.
(define-place-macro): New macro.
(first, rest): Places redefined using define-place-macro, replacing
the old hack of copying the expanders from one table entry to another.

* txr.1: Documented place macros.

1 files changed, 24 insertions, 11 deletions

diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl
index 9a3de089..0356e81e 100644
--- a/share/txr/stdlib/place.tl
+++ b/share/txr/stdlib/place.tl
@@ -27,6 +27,7 @@
   (defvar *place-clobber-expander* (hash))
   (defvar *place-update-expander* (hash))
   (defvar *place-delete-expander* (hash))
+  (defvar *place-macro* (hash))
   (defvar sys:*lisp1* nil)
 
   (defun sys:eval-err (. params)
@@ -125,18 +126,30 @@
   ^(let ,(zip syms (repeat '((gensym)))) ,*body))
 
 (macro-time
+  (defun sys:trigger-load (form)
+    (when (consp form) (symbol-function (car form)))
+    form)
+
+  (defun sys:pl-expand (unex-place env)
+    (let ((ex-place (sys:expand unex-place env)))
+      (sys:trigger-load
+        (iflet ((pm-expander [*place-macro* (and (consp ex-place)
+                                                 (car ex-place))]))
+          [pm-expander ex-place]
+          ex-place))))
+
   (defun call-update-expander (getter setter unex-place env body)
-    (let* ((place (sys:expand unex-place env))
+    (let* ((place (sys:pl-expand unex-place env))
            (expander (get-update-expander place)))
       [expander getter setter place body]))
 
   (defun call-clobber-expander (ssetter unex-place env body)
-    (let* ((place (sys:expand unex-place env))
+    (let* ((place (sys:pl-expand unex-place env))
            (expander (get-clobber-expander place)))
       [expander ssetter place body]))
 
   (defun call-delete-expander (deleter unex-place env body)
-    (let* ((place (sys:expand unex-place env))
+    (let* ((place (sys:pl-expand unex-place env))
            (expander (get-delete-expander place)))
       [expander deleter place body])))
 
@@ -296,6 +309,11 @@
                    (tree-bind ,args (cdr ,place)
                       ,delete-body)))))))))
 
+(defmacro define-place-macro (name place-destructuring-args . body)
+  (with-gensyms (name-dummy)
+    ^(sethash *place-macro* ',name
+              (tb ((,name-dummy ,*place-destructuring-args)) ,*body))))
+
 (defplace (sys:var arg) body
   (getter setter
     ^(macrolet ((,getter () ^(sys:var ,',arg))
@@ -551,14 +569,6 @@
     ^(macrolet ((,deleter () ^(makunbound ,',sym-expr)))
        ,*body)))
 
-(macro-time
-  (each ((from '(car cdr))
-         (to '(first rest)))
-    (each ((table (list *place-update-expander*
-                        *place-clobber-expander*
-                        *place-delete-expander*)))
-      (set [table to] [table from]))))
-
 (defmacro define-modify-macro (name lambda-list function)
   (let ((cleaned-lambda-list (mapcar [iffi consp car]
                                      (remql : lambda-list))))
@@ -601,3 +611,6 @@
        ^(placelet* (,*(zip temps places))
           (symacrolet (,*(zip syms temps))
             ,*body)))))
+
+(define-place-macro first (obj) ^(car ,obj))
+(define-place-macro rest (obj) ^(cdr ,obj))