* 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.

4 files changed, 85 insertions, 16 deletions

diff --git a/ChangeLog b/ChangeLog
index 7393869b..76f963d5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,20 @@
 2015-07-22  Kaz Kylheku  <kaz@kylheku.com>
 
+	* 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.
+
+2015-07-22  Kaz Kylheku  <kaz@kylheku.com>
+
 	* lib.c (obj_print, obj_pprint): Bugfix: incorrect
 	value returned when printing dwim forms, due to
 	mutating the obj variable.
diff --git a/lisplib.c b/lisplib.c
index 7fc92021..014e095b 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -56,7 +56,7 @@ static val place_set_entries(val dlt, val fun)
 {
   val name[] = {
     lit("*place-clobber-expander*"), lit("*place-update-expander*"),
-    lit("*place-delete-expander*"),
+    lit("*place-delete-expander*"), lit("*place-macro*"),
     lit("get-update-expander"), lit("get-clobber-expander"),
     lit("get-delete-expander"),
     lit("place-form-p"),
@@ -68,7 +68,7 @@ static val place_set_entries(val dlt, val fun)
     lit("set"), lit("pset"), lit("zap"), lit("flip"), lit("inc"), lit("dec"),
     lit("push"), lit("pop"), lit("swap"), lit("shift"), lit("rotate"),
     lit("pushnew"), lit("del"),
-    lit("defplace"), lit("define-modify-macro"),
+    lit("defplace"), lit("define-place-macro"), lit("define-modify-macro"),
     lit("placelet"), lit("placelet*"),
     nil
   };
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))
diff --git a/txr.1 b/txr.1
index 2cebedce..b6b952a8 100644
--- a/txr.1
+++ b/txr.1
@@ -9924,10 +9924,14 @@ are both open-ended. Code can be written quite easily in \*(TL to introduce
 new kinds of places, as well as new place-mutating operators.
 New places can be introduced with the help of the
 .code defplace
-macro.  New place update macros (place operators) are written using the
+macro, or possibly the
+.code define-place-macro
+macro in simple cases when a new syntactic place can be expressed as a
+transformation to the syntax of an existing place.
+New place update macros (place operators) are written using the
 ordinary macro definer
-.code defmacro
-but with the help of special utility macros called
+.codn defmacro ,
+with the help of special utility macros called
 .codn with-update-expander ,
 .codn with-clobber-expander ,
 and
@@ -30251,6 +30255,43 @@ cells:
          ,body)))
 .cble
 
+.coNP Macro @ define-place-macro
+.synb
+.mets (define-place-macro < name < macro-style-params
+.mets \ \  << body-form *)
+.syne
+.desc
+In some situations, an equivalence exists between two forms, only one
+of which is recognized as a place. The
+.code define-place-macro
+macro can be used to establish a form as a place in terms of a translation to
+an equivalent form which is already a place.
+
+The
+.code define-place-macro
+has the same syntax as
+.codn defmacro .
+It specifies a macro transformation for a compound form which has the
+.meta name
+symbol in its leftmost position.
+This macro expansion is applied when such a form is used as a place.
+It is applied after all other expansions, and no other macro-expansions
+are applied afterward.
+
+.TP* "Example:"
+
+Implementation of
+.code first
+in terms of
+.codn car :
+
+.cblk
+  (define-place-macro first (obj)
+    ^(car ,obj))
+.cble
+
+.coNP Operator @ defmacro
+
 .coNP Macro @ rlet
 .synb
 .mets (rlet >> ({( sym << init-form )}*) << body-form *)