file layout: moving share/txr/stdlib to stdlib.

This affects run-time also. Txr installations where the
executable is not in directory ending in ${bindir}
will look for stdlib rather than share/txr/stdlib,
relative to the determined installation directory.

* txr.c (sysroot_init): If we detect relative to the short
name, or fall back on the program directory, use stdlib
rather than share/txr/stdlib as the stdlib_path.

* INSTALL: Update some installation notes not to refer to
share/txr/stdlib but stdlib.

* Makefile (STDLIB_SRCS): Refer to stdlib, not
share/txr/stdlib.
(clean): In unconfigured mode, remove the old share/txr/stdlib
entirely.  Remove .tlo files from stdlib.
(install): Install lib materials from stdlib.

* txr.1: Updated documentation under Deployment Directory Structure.

* share/txr/stdlib/{asm,awk,build,cadr}.tl:
Renamed to stdlib/{asm,awk,build,cadr}.tl.

* share/txr/stdlib/{compiler,conv,copy-file,debugger}.tl:
Renamed to stdlib/{compiler,conv,copy-file,debugger}.tl.

* share/txr/stdlib/{defset,doc-lookup,doc-syms,doloop}.tl:
Renamed to stdlib/{defset,doc-lookup,doc-syms,doloop}.tl.

* share/txr/stdlib/{each-prod,error,except,ffi}.tl:
Renamed to stdlib/{each-prod,error,except,ffi}.tl.

* share/txr/stdlib/{getopts,getput,hash,ifa}.tl:
Renamed to stdlib/{getopts,getput,hash,ifa}.tl.

* share/txr/stdlib/{keyparams,match,op,optimize}.tl:
Renamed to stdlib/{keyparams,match,op,optimize}.tl.

* share/txr/stdlib/{package,param,path-test,pic}.tl:
Renamed to stdlib/{package,param,path-test,pic}.tl.

* share/txr/stdlib/{place,pmac,quips,save-exe}.tl:
Renamed to stdlib/{place,pmac,quips,save-exe}.tl.

* share/txr/stdlib/{socket,stream-wrap,struct,tagbody}.tl:
Renamed to stdlib/{socket,stream-wrap,struct,tagbody}.tl.

* share/txr/stdlib/{termios,trace,txr-case,type}.tl:
Renamed to stdlib/{termios,trace,txr-case,type}.tl.

* share/txr/stdlib/{ver,vm-param,with-resources,with-stream}.tl:
Renamed to stdlib/{ver,vm-param,with-resources,with-stream}.tl.

* share/txr/stdlib/yield.tl: Renamed to stdlib/yield.tl.

* share/txr/stdlib/{txr-case,ver}.txr:
Renamed to stdlib/{txr-case,ver}.txr.

* gencadr.txr: Update to stdlib/place.tl.

* genman.txr: Update to stdlib/cadr.tl.

1 files changed, 971 insertions, 0 deletions

diff --git a/stdlib/place.tl b/stdlib/place.tl
new file mode 100644
index 00000000..3ee0ea8c
--- /dev/null
+++ b/stdlib/place.tl
@@ -0,0 +1,971 @@
+;; Copyright 2015-2021
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice, this
+;;    list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;;    this list of conditions and the following disclaimer in the documentation
+;;    and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(defvar *place-clobber-expander* (hash))
+(defvar *place-update-expander* (hash))
+(defvar *place-delete-expander* (hash))
+(defvar *place-macro* (hash))
+(defvar sys:*pl-env* nil)
+(defvar sys:*pl-form* nil)
+
+(defun sys:eval-err (. params)
+  (throwf 'eval-error . params))
+
+(defun sys:sym-update-expander (getter-name setter-name
+                                place-expr op-body)
+  ^(macrolet ((,getter-name () ',place-expr)
+              (,setter-name (val-expr) ^(sys:setq ,',place-expr
+                                                  ,val-expr)))
+     ,op-body))
+
+(defun sys:sym-clobber-expander (simple-setter-name
+                                 place-expr op-body)
+  ^(macrolet ((,simple-setter-name (val-expr)
+                 ^(sys:setq ,',place-expr ,val-expr)))
+     ,op-body))
+
+(defun sys:sym-delete-expander (deleter-name
+                                place-expr . op-body)
+  ^(macrolet ((,deleter-name (:env env)
+                (when (lexical-var-p env ',place-expr)
+                  (sys:eval-err "~s is a lexical variable, thus not deletable"
+                                ',place-expr))
+                ^(prog1
+                   (symbol-value ',',place-expr)
+                   (makunbound ',',place-expr))))
+     ,*op-body))
+
+(defun sys:get-place-macro (sym)
+  (or [*place-macro* sym]
+      (progn (sys:try-load sym) [*place-macro* sym])))
+
+(defun sys:pl-expand (unex-place env)
+  (while t
+    (let ((place unex-place)
+          pm-expander)
+      (while (and (consp place)
+                  (sys:setq pm-expander (sys:get-place-macro (car place)))
+                  (sys:setq place (sys:set-macro-ancestor [pm-expander place] place))
+                  (neq place unex-place))
+        (sys:setq unex-place place))
+      (sys:setq place (macroexpand-1 place env))
+      (when (or (eq place unex-place)
+                (null place)
+                (and (atom place) (not (symbolp place))))
+        (return-from sys:pl-expand place))
+      (sys:setq unex-place place))))
+
+(defun place-form-p (unex-place env)
+  (let ((place (sys:pl-expand unex-place env)))
+    (or (bindable place)
+        (and (consp place) [*place-update-expander* (car place)] t))))
+
+(defun get-update-expander (place)
+  (cond
+    ((symbolp place) (fun sys:sym-update-expander))
+    ((consp place) (or [*place-update-expander* (car place)]
+                       (sys:eval-err "~s is not an assignable place" place)))
+    (t (sys:eval-err "form ~s is not syntax denoting an assignable place" place))))
+
+(defun get-clobber-expander (place)
+  (cond
+    ((symbolp place) (fun sys:sym-clobber-expander))
+    ((consp place) (or [*place-clobber-expander* (car place)]
+                       (iflet ((fun [*place-update-expander* (car place)]))
+                          (op apply fun (gensym) @1 @2 @rest))
+                       (sys:eval-err "~s is not an assignable place" place)))
+    (t (sys:eval-err "form ~s is not syntax denoting an assignable place" place))))
+
+(defun get-delete-expander (place)
+  (cond
+    ((symbolp place) (fun sys:sym-delete-expander))
+    ((consp place) (or [*place-delete-expander* (car place)]
+                       (sys:eval-err "~s is not a deletable place" place)))
+    (t (sys:eval-err "form ~s is not syntax denoting a deletable place" place))))
+
+(defun sys:r-s-let-expander (bindings body e letsym pred)
+  (let ((exp-bindings (mapcar (aret ^(,@1 ,(macroexpand @2 e))) bindings)))
+    (let ((renames [keep-if pred exp-bindings second])
+          (regular [remove-if pred exp-bindings second]))
+    (cond ((and renames regular)
+            ^(symacrolet ,renames
+               (,letsym ,regular ,*body)))
+          (renames ^(symacrolet ,renames ,*body))
+          (regular ^(,letsym ,regular ,*body))
+          (t ^(progn ,*body))))))
+
+(defmacro rlet (bindings :env e . body)
+  [sys:r-s-let-expander bindings body e 'let constantp])
+
+(defmacro slet (bindings :env e . body)
+  (sys:r-s-let-expander bindings body e 'let [orf constantp bindable]))
+
+(defmacro alet (bindings :env e . body)
+  (let ((exp-bindings (mapcar (aret ^(,@1 ,(macroexpand @2 e))) bindings)))
+    (if [some exp-bindings constantp second]
+      [sys:r-s-let-expander exp-bindings body e 'alet constantp]
+      ^(,(if [all exp-bindings bindable second]
+           'symacrolet 'let)
+         ,exp-bindings ,*body))))
+
+(defmacro with-gensyms (syms . body)
+  ^(let ,(zip syms (repeat '((gensym)))) ,*body))
+
+(defun sys:propagate-ancestor (to-tree from-form . syms)
+  (unless (macro-ancestor to-tree)
+    (tree-case to-tree
+      ((a . d)
+       (when (memq a syms)
+         (sys:set-macro-ancestor to-tree from-form))
+       (sys:propagate-ancestor a from-form . syms)
+       (sys:propagate-ancestor d from-form . syms))))
+  to-tree)
+
+(defun call-update-expander (getter setter unex-place env body)
+  (sys:propagate-ancestor body unex-place getter setter)
+  (let* ((place (sys:pl-expand unex-place env))
+         (expander (get-update-expander place))
+         (sys:*pl-env* env)
+         (sys:*pl-form* unex-place)
+         (expansion [expander getter setter place body])
+         (expansion-ex (expand expansion env)))
+    (sys:propagate-ancestor expansion-ex place getter setter)))
+
+(defun call-clobber-expander (ssetter unex-place env body)
+  (sys:propagate-ancestor body unex-place ssetter)
+  (let* ((place (sys:pl-expand unex-place env))
+         (expander (get-clobber-expander place))
+         (sys:*pl-env* env)
+         (sys:*pl-form* unex-place)
+         (expansion [expander ssetter place body])
+         (expansion-ex (expand expansion env)))
+    (sys:propagate-ancestor expansion-ex place ssetter)))
+
+(defun call-delete-expander (deleter unex-place env body)
+  (sys:propagate-ancestor body unex-place deleter)
+  (let* ((place (sys:pl-expand unex-place env))
+         (expander (get-delete-expander place))
+         (sys:*pl-env* env)
+         (sys:*pl-form* unex-place)
+         (expansion [expander deleter place body])
+         (expansion-ex (expand expansion env)))
+    (sys:propagate-ancestor expansion-ex place deleter)))
+
+(defmacro with-update-expander ((getter setter) unex-place env body)
+  ^(with-gensyms (,getter ,setter)
+     (call-update-expander ,getter ,setter ,unex-place ,env ,body)))
+
+(defmacro with-clobber-expander ((ssetter) unex-place env body)
+  ^(with-gensyms (,ssetter)
+     (call-clobber-expander ,ssetter ,unex-place ,env ,body)))
+
+(defmacro with-delete-expander ((deleter) unex-place env body)
+  ^(with-gensyms (,deleter)
+     (call-delete-expander ,deleter ,unex-place ,env ,body)))
+
+(defmacro set (:env env . place-value-pairs)
+  (let ((assign-forms (mapcar (tb ((place : (value nil value-present-p)))
+                                (unless value-present-p
+                                  (sys:eval-err "set: arguments must be pairs"))
+                                (with-clobber-expander (ssetter) place env
+                                   ^(,ssetter ,value)))
+                              (tuples 2 place-value-pairs))))
+    (if (cdr assign-forms)
+      ^(progn ,*assign-forms)
+      (car assign-forms))))
+
+(defmacro pset (:env env . place-value-pairs)
+  (let ((len (length place-value-pairs)))
+    (cond
+      ((oddp len) (sys:eval-err "pset: arguments must be pairs"))
+      ((<= len 2) ^(set ,*place-value-pairs))
+      (t (let* ((pvtgs (mapcar (tb ((a b))
+                                 (list a b (gensym) (gensym) (gensym)))
+                               (tuples 2 place-value-pairs)))
+                (ls (reduce-left (tb ((lets stores) (place value temp getter setter))
+                                     (list ^((,temp ,value) ,*lets)
+                                           ^((,setter ,temp) ,*stores)))
+                                 pvtgs '(nil nil)))
+                (lets (first ls))
+                (stores (second ls))
+                (body-form ^(rlet (,*lets) ,*stores)))
+           (reduce-left (tb (accum-form (place value temp getter setter))
+                          (call-update-expander getter setter
+                                                place env accum-form))
+                        pvtgs body-form))))))
+
+(defmacro zap (place : (new-val nil) :env env)
+  (with-update-expander (getter setter) place env
+    ^(prog1 (,getter) (,setter ,new-val))))
+
+(defmacro flip (place :env env)
+  (with-update-expander (getter setter) place env
+    ^(,setter (not (,getter)))))
+
+(defmacro inc (place : (delta 1) :env env)
+  (with-update-expander (getter setter) place env
+    (caseql delta
+      (0 place)
+      (1 ^(,setter (succ (,getter))))
+      (2 ^(,setter (ssucc (,getter))))
+      (3 ^(,setter (sssucc (,getter))))
+      (t ^(,setter (+ (,getter) ,delta))))))
+
+(defmacro dec (place : (delta 1) :env env)
+  (with-update-expander (getter setter) place env
+    (caseql delta
+      (0 place)
+      (1 ^(,setter (pred (,getter))))
+      (2 ^(,setter (ppred (,getter))))
+      (3 ^(,setter (pppred (,getter))))
+      (t ^(,setter (- (,getter) ,delta))))))
+
+(defmacro pinc (place : (delta 1) :env env)
+  (with-gensyms (oldval)
+    (with-update-expander (getter setter) place env
+      (caseql delta
+        (0 place)
+        (1 ^(let ((,oldval (,getter))) (,setter (succ ,oldval)) ,oldval))
+        (2 ^(let ((,oldval (,getter))) (,setter (ssucc ,oldval)) ,oldval))
+        (3 ^(let ((,oldval (,getter))) (,setter (sssucc ,oldval)) ,oldval))
+        (t ^(let ((,oldval (,getter))) (,setter (+ ,oldval, delta)) ,oldval))))))
+
+(defmacro pdec (place : (delta 1) :env env)
+  (with-gensyms (oldval)
+    (with-update-expander (getter setter) place env
+      (caseql delta
+        (0 place)
+        (1 ^(let ((,oldval (,getter))) (,setter (pred ,oldval)) ,oldval))
+        (2 ^(let ((,oldval (,getter))) (,setter (ppred ,oldval)) ,oldval))
+        (3 ^(let ((,oldval (,getter))) (,setter (pppred ,oldval)) ,oldval))
+        (t ^(let ((,oldval (,getter))) (,setter (- ,oldval, delta)) ,oldval))))))
+
+(defmacro swap (place-0 place-1 :env env)
+  (with-gensyms (tmp)
+    (with-update-expander (getter-0 setter-0) place-0 env
+      (with-update-expander (getter-1 setter-1) place-1 env
+        ^(let ((,tmp (,getter-0)))
+           (,setter-0 (,getter-1))
+           (,setter-1 ,tmp))))))
+
+(defmacro push (new-item place :env env)
+  (with-gensyms (new-sym)
+    ^(alet ((,new-sym ,new-item))
+       ,(with-update-expander (getter setter) place env
+          ^(,setter (cons ,new-sym (,getter)))))))
+
+(defmacro pop (place :env env)
+  (with-gensyms (tmp)
+    (with-update-expander (getter setter) place env
+      ^(alet ((,tmp (,getter)))
+         (prog1 (car ,tmp) (,setter (cdr ,tmp)))))))
+
+(defmacro pushnew (new-item place :env env :
+                            (testfun :)
+                            (keyfun :))
+  (with-update-expander (getter setter) place env
+    (with-gensyms (new-item-sym old-list-sym)
+      ^(rlet ((,new-item-sym ,new-item))
+         ,(with-update-expander (getter setter) place env
+            ^(let ((,old-list-sym (,getter)))
+               (if (member ,new-item-sym ,old-list-sym ,testfun ,keyfun)
+                 ,old-list-sym
+                 (,setter (cons ,new-item-sym ,old-list-sym)))))))))
+
+(defmacro shift (:form f :env env . places)
+  (tree-case places
+    (() (compile-error f "need at least two arguments"))
+    ((place) (compile-error f "need at least two arguments"))
+    ((place newvalue)
+     (with-update-expander (getter setter) place env
+        ^(prog1 (,getter) (,setter ,newvalue))))
+    ((place . others)
+      (with-update-expander (getter setter) place env
+        ^(prog1 (,getter) (,setter (shift ,*others)))))))
+
+(defmacro rotate (:env env . places)
+  (tree-case places
+    (() ())
+    ((fplace) fplace)
+    ((fplace . rplaces)
+     (with-gensyms (tmp)
+       (with-update-expander (getter-f setter-f) fplace env
+         ^(let ((,tmp (,getter-f)))
+            (,setter-f (shift ,*rplaces ,tmp))
+            ,tmp))))))
+
+(defmacro test-set (:env env place)
+  (with-update-expander (getter setter) place env
+    ^(unless (,getter)
+       (,setter t))))
+
+(defmacro test-clear (:env env place)
+  (with-update-expander (getter setter) place env
+    ^(when (,getter)
+       (,setter nil)
+       t)))
+
+(defmacro compare-swap (:env env comp-fun place comp-val store-val)
+  (with-update-expander (getter setter) place env
+    ^(when (,comp-fun (,getter) ,comp-val)
+       (,setter ,store-val)
+       t)))
+
+(defmacro test-inc (place : (delta 1) (upfrom-val 0))
+  ^(eql (pinc ,place ,delta) ,upfrom-val))
+
+(defmacro test-dec (place : (delta 1) (downto-val 0))
+  ^(eql (dec ,place ,delta) ,downto-val))
+
+(defmacro del (place :env env)
+  (with-delete-expander (deleter) place env
+    ^(,deleter)))
+
+(defmacro lset (:form f . places-source)
+  (let ((places (butlast places-source))
+        (source (last places-source))
+        (orig (gensym))
+        (iter (gensym)))
+    (unless places
+      (compile-error f "require one or more places followed by expression"))
+    ^(let* ((,orig ,(car source))
+            (,iter ,orig))
+       ,*(butlast (mappend (ret ^((set ,@1 (car ,iter)) (set ,iter (cdr ,iter))))
+                           places))
+       ,orig)))
+
+(defmacro upd (place . opip-args)
+  (with-gensyms (pl)
+    ^(placelet ((,pl ,place))
+       (set ,pl (call (opip ,*opip-args) ,pl)))))
+
+(defmacro defplace (place-destructuring-args body-sym
+                    (getter-sym setter-sym update-body) :
+                    ((ssetter-sym clobber-body))
+                    ((deleter-sym delete-body)))
+  (let ((name (car place-destructuring-args))
+        (args (cdr place-destructuring-args)))
+    (unless (and name
+                 (symbolp name)
+                 (not (keywordp name))
+                 (not (eq t name)))
+      (compile-error sys:*pl-form* "~s cannot be used as a place name" name))
+    (with-gensyms (place)
+      ^(progn
+         (sethash *place-update-expander* ',name
+           (lambda (,getter-sym ,setter-sym ,place ,body-sym)
+             (tree-bind ,args (cdr ,place)
+                ,update-body)))
+         ,*(if ssetter-sym
+            ^((sethash *place-clobber-expander* ',name
+                (lambda (,ssetter-sym ,place ,body-sym)
+                  (tree-bind ,args (cdr ,place)
+                     ,clobber-body)))))
+         ,*(if deleter-sym
+             ^((sethash *place-delete-expander* ',name
+                 (lambda (,deleter-sym ,place ,body-sym)
+                   (tree-bind ,args (cdr ,place)
+                      ,delete-body)))))
+         ',name))))
+
+(defmacro define-place-macro (name place-destructuring-args . body)
+  (with-gensyms (name-dummy args)
+    ^(progn
+       (sethash *place-macro* ',name
+                (lambda (,args)
+                  (mac-param-bind ,args
+                                  (,name-dummy ,*place-destructuring-args)
+                                  ,args ,*body)))
+       ',name)))
+
+(defplace (sys:var arg) body
+  (getter setter
+    ^(macrolet ((,getter () ^(sys:var ,',arg))
+                (,setter (val) ^(sys:setq ,'(sys:var ,arg) ,val)))
+       ,body)))
+
+(defplace (sys:l1-val arg) body
+  (getter setter
+    ^(macrolet ((,getter () ^(sys:l1-val ,',arg))
+                (,setter (val) ^(sys:l1-setq ,',arg ,val)))
+         ,body))
+  (ssetter
+    ^(macrolet ((,ssetter (val) ^(sys:l1-setq ,',arg ,val)))
+       ,body)))
+
+(defplace (sys:lisp1-value arg) body
+  (getter setter
+    ^(macrolet ((,getter () ^(sys:lisp1-value ,',arg))
+                (,setter (val) ^(sys:lisp1-setq ,',arg ,val)))
+         ,body))
+  (ssetter
+    ^(macrolet ((,ssetter (val) ^(sys:lisp1-setq ,',arg ,val)))
+       ,body)))
+
+(defplace (car cell) body
+  (getter setter
+    (with-gensyms (cell-sym)
+      ^(slet ((,cell-sym ,cell))
+         (macrolet ((,getter () ^(car ,',cell-sym))
+                    (,setter (val) ^(sys:rplaca ,',cell-sym ,val)))
+           ,body))))
+  (ssetter
+    ^(macrolet ((,ssetter (val) ^(sys:rplaca ,',cell ,val)))
+      ,body))
+  (deleter
+    ^(macrolet ((,deleter () ^(pop ,',cell)))
+       ,body)))
+
+(defplace (cdr cell) body
+  (getter setter
+    (with-gensyms (cell-sym)
+      ^(slet ((,cell-sym ,cell))
+         (macrolet ((,getter () ^(cdr ,',cell-sym))
+                    (,setter (val) ^(sys:rplacd ,',cell-sym ,val)))
+           ,body))))
+  (ssetter
+    ^(macrolet ((,ssetter (val) ^(sys:rplacd ,',cell ,val)))
+       ,body))
+  (deleter
+    ^(macrolet ((,deleter ()
+                  (with-gensyms (tmp)
+                    (with-update-expander (cgetter csetter) ',cell nil
+                      ^(let ((,tmp (,cgetter)))
+                         (prog1 (cdr ,tmp) (,csetter (car ,tmp))))))))
+       ,body)))
+
+(defplace (nthcdr index list) body
+  (getter setter
+    (with-gensyms (index-sym list-sym sentinel-head-sym parent-cell-sym)
+      (if (place-form-p list sys:*pl-env*)
+        (with-update-expander (lgetter lsetter) list sys:*pl-env*
+          ^(alet ((,index-sym ,index)
+                  (,list-sym (,lgetter)))
+             (let* ((,sentinel-head-sym (cons nil ,list-sym))
+                    (,parent-cell-sym (nthcdr ,index-sym ,sentinel-head-sym)))
+               (macrolet ((,getter () ^(cdr ,',parent-cell-sym))
+                          (,setter (val)
+                            ^(prog1 (sys:rplacd ,',parent-cell-sym ,val)
+                                    (,',lsetter (cdr ,',sentinel-head-sym)))))
+                 ,body))))
+        ^(alet ((,index-sym ,index)
+                (,list-sym ,list))
+           (let ((,parent-cell-sym (nthcdr (pred ,index-sym) ,list-sym)))
+             (macrolet ((,getter () ^(cdr ,',parent-cell-sym))
+                        (,setter (val)
+                          ^(sys:rplacd ,',parent-cell-sym ,val)))
+               ,body)))))))
+
+(defplace (nthlast index list) body
+  (getter setter
+    (with-gensyms (index-sym list-sym sentinel-head-sym parent-cell-sym)
+      (if (place-form-p list sys:*pl-env*)
+        (with-update-expander (lgetter lsetter) list sys:*pl-env*
+          ^(alet ((,index-sym ,index)
+                  (,list-sym (,lgetter)))
+             (let* ((,sentinel-head-sym (cons nil ,list-sym))
+                    (,parent-cell-sym (nthlast (succ ,index-sym)
+                                               ,sentinel-head-sym)))
+               (macrolet ((,getter () ^(cdr ,',parent-cell-sym))
+                          (,setter (val)
+                            ^(prog1 (sys:rplacd ,',parent-cell-sym ,val)
+                                    (,',lsetter (cdr ,',sentinel-head-sym)))))
+                 ,body))))
+        ^(alet ((,index-sym index)
+                (,list-sym ,list))
+           (let ((,parent-cell-sym (nthlast (succ ,index-sym) ,list-sym)))
+             (macrolet ((,getter () ^(cdr ,',parent-cell-sym))
+                        (,setter (val)
+                          ^(sys:rplacd ,',parent-cell-sym ,val)))
+               ,body)))))))
+
+(defplace (butlastn num list) body
+  (getter setter
+    (with-gensyms (num-sym list-sym head-sym tail-sym val-sym)
+      (with-update-expander (lgetter lsetter) list sys:*pl-env*
+        ^(alet ((,num-sym ,num)
+                (,list-sym (,lgetter)))
+           (let* ((,tail-sym (nthlast ,num-sym ,list-sym))
+                  (,head-sym (ldiff ,list-sym ,tail-sym)))
+             (macrolet ((,getter () ,head-sym)
+                        (,setter (val)
+                           ^(alet ((,',val-sym ,val))
+                              (progn (,',lsetter (append ,',val-sym
+                                                         ,',tail-sym))
+                                     ,',val-sym))))
+               ,body)))))))
+
+(defplace (vecref vector index :whole args) body
+  (getter setter
+    (with-gensyms (vec-sym ind-sym)
+      ^(alet ((,vec-sym ,vector)
+              (,ind-sym ,index))
+         (macrolet ((,getter () ^(vecref ,',vec-sym ,',ind-sym))
+                    (,setter (val) ^(refset ,',vec-sym ,',ind-sym ,val)))
+            ,body))))
+  (ssetter
+    ^(macrolet ((,ssetter (val) ^(refset ,*',args ,val)))
+       ,body))
+  (deleter
+    (with-gensyms (vec-sym ind-sym)
+      ^(alet ((,vec-sym ,vector)
+              (,ind-sym ,index))
+         (macrolet ((,deleter ()
+                       ^(prog1 (vecref ,',vec-sym ,',ind-sym)
+                               (replace-vec ,',vec-sym nil
+                                            ,',ind-sym (succ ,',ind-sym)))))
+           ,body)))))
+
+(defplace (chr-str string index :whole args) body
+  (getter setter
+    (with-gensyms (str-sym ind-sym)
+      ^(alet ((,str-sym ,string)
+              (,ind-sym ,index))
+         (macrolet ((,getter () ^(chr-str ,',str-sym ,',ind-sym))
+                    (,setter (val) ^(chr-str-set ,',str-sym ,',ind-sym ,val)))
+            ,body))))
+  (ssetter
+    ^(macrolet ((,ssetter (val) ^(chr-str-set ,*',args ,val)))
+       ,body))
+  (deleter
+    (with-gensyms (str-sym ind-sym)
+      ^(alet ((,str-sym ,string)
+              (,ind-sym ,index))
+         (macrolet ((,deleter ()
+                       ^(prog1 (chr-str ,',str-sym ,',ind-sym)
+                               (replace-str ,',str-sym nil
+                                            ,',ind-sym (succ ,',ind-sym)))))
+           ,body)))))
+
+(defplace (ref seq index :whole args) body
+  (getter setter
+    (with-gensyms (seq-sym ind-sym)
+      ^(alet ((,seq-sym ,seq)
+              (,ind-sym ,index))
+         (macrolet ((,getter () ^(ref ,',seq-sym ,',ind-sym))
+                    (,setter (val) ^(refset ,',seq-sym ,',ind-sym ,val)))
+            ,body))))
+  (ssetter
+    ^(macrolet ((,ssetter (val) ^(refset ,*',args ,val)))
+       ,body))
+  (deleter
+    (with-gensyms (seq-sym ind-sym)
+      ^(alet ((,seq-sym ,seq)
+              (,ind-sym ,index))
+         (macrolet ((,deleter ()
+                       ^(prog1 (ref ,',seq-sym ,',ind-sym)
+                               (replace ,',seq-sym nil
+                                        ,',ind-sym (succ ,',ind-sym)))))
+           ,body)))))
+
+(defplace (sub seq :whole args : (from 0) (to t)) body
+  (getter setter
+    (with-gensyms (seq-sym from-sym to-sym v-sym)
+      (with-update-expander (seq-getter seq-setter) seq sys:*pl-env*
+        ^(alet ((,seq-sym (,seq-getter))
+                (,from-sym ,from)
+                (,to-sym ,to))
+           (macrolet ((,getter () ^(sub ,',seq-sym ,',from-sym ,',to-sym))
+                      (,setter (val)
+                        ^(alet ((,',v-sym ,val))
+                           (,',seq-setter (replace ,',seq-sym ,',v-sym
+                                                   ,',from-sym ,',to-sym))
+                           ,',v-sym)))
+              ,body)))))
+  (ssetter
+    (with-gensyms (seq-sym from-sym to-sym v-sym)
+      (with-update-expander (seq-getter seq-setter) seq sys:*pl-env*
+        ^(macrolet ((,ssetter (val)
+                     ^(alet ((,',seq-sym (,',seq-getter))
+                             (,',from-sym ,',from)
+                             (,',to-sym ,',to)
+                             (,',v-sym ,val))
+                        (,',seq-setter (replace ,',seq-sym ,',v-sym
+                                                ,',from-sym ,',to-sym))
+                        ,',v-sym)))
+        ,body))))
+  (deleter
+    (with-gensyms (seq-sym from-sym to-sym)
+      (with-update-expander (seq-getter seq-setter) seq sys:*pl-env*
+        ^(alet ((,seq-sym (,seq-getter))
+                (,from-sym ,from)
+                (,to-sym ,to))
+           (macrolet ((,deleter ()
+                         ^(prog1
+                            (sub ,',seq-sym ,',from-sym ,',to-sym)
+                            (,',seq-setter (replace ,',seq-sym nil
+                                                    ,',from-sym ,',to-sym)))))
+             ,body))))))
+
+(defplace (gethash hash key : (default nil have-default-p)) body
+  (getter setter
+    (with-gensyms (entry-sym)
+      ^(let ((,entry-sym (inhash ,hash ,key ,default)))
+         (macrolet ((,getter () ^(cdr ,',entry-sym))
+                    (,setter (val) ^(sys:rplacd ,',entry-sym ,val)))
+            ,body))))
+  nil
+  (deleter
+    ^(macrolet ((,deleter ()
+                  (if ,have-default-p
+                    (with-gensyms (entry-sym
+                                   dfl-sym)
+                      ^(alet ((,entry-sym (inhash ,',hash ,',key))
+                              (,dfl-sym ,',default))
+                         (if ,entry-sym
+                           (remhash ,',hash ,',key)
+                           ,dfl-sym)))
+                    ^(remhash ,',hash ,',key))))
+       ,body)))
+
+(defplace (hash-userdata hash) body
+  (getter setter
+    (with-gensyms (hash-sym)
+      ^(slet ((,hash-sym ,hash))
+         (macrolet ((,getter () ^(hash-userdata ,',hash-sym))
+                    (,setter (val) ^(set-hash-userdata ,',hash-sym ,val)))
+            ,body))))
+  (ssetter
+    ^(macrolet ((,ssetter (val)
+                  ^(set-hash-userdata ,',hash ,val)))
+      ,body)))
+
+(defplace (dwim obj-place :env env . args) body
+  (getter setter
+    (with-gensyms (ogetter-sym osetter-sym obj-sym newval-sym)
+      (let ((arg-syms (mapcar (ret (gensym)) args)))
+        (if (place-form-p obj-place sys:*pl-env*)
+          (with-update-expander (ogetter-sym osetter-sym)
+                                ^(sys:l1-val ,obj-place) sys:*pl-env*
+            ^(rlet ((,obj-sym (,ogetter-sym))
+                    ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) arg-syms args))
+               (macrolet ((,getter ()
+                            '[,obj-sym ,*arg-syms])
+                          (,setter (val)
+                            ^(rlet ((,',newval-sym ,val))
+                               (,',osetter-sym
+                                 (sys:dwim-set t ,',obj-sym
+                                               ,*',arg-syms ,',newval-sym))
+                               ,',newval-sym)))
+                 ,body)))
+          ^(rlet ((,obj-sym ,obj-place)
+                  ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) arg-syms args))
+             (macrolet ((,getter ()
+                          '[,obj-sym ,*arg-syms])
+                        (,setter (val)
+                          ^(rlet ((,',newval-sym ,val))
+                             (sys:dwim-set nil ,',obj-sym
+                                           ,*',arg-syms ,',newval-sym)
+                             ,',newval-sym)))
+               ,body))))))
+  (ssetter
+    (with-gensyms (osetter-sym ogetter-sym obj-sym newval-sym)
+      (let ((arg-syms (mapcar (ret (gensym)) args)))
+        (if (place-form-p obj-place sys:*pl-env*)
+          (with-update-expander (ogetter-sym osetter-sym)
+                                ^(sys:l1-val ,obj-place) sys:*pl-env*
+            ^(macrolet ((,ssetter (val)
+                         ^(rlet ((,',obj-sym (,',ogetter-sym))
+                                 ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2)))
+                                           ',arg-syms ',args)
+                                 (,',newval-sym ,val))
+                            (,',osetter-sym
+                              (sys:dwim-set t ,',obj-sym
+                                            ,*',arg-syms
+                                            ,',newval-sym))
+                            ,',newval-sym)))
+                 ,body))
+          ^(macrolet ((,ssetter (val)
+                       ^(rlet ((,',obj-sym ,',obj-place)
+                               ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2)))
+                                         ',arg-syms ',args)
+                               (,',newval-sym ,val))
+                          (sys:dwim-set nil ,',obj-sym
+                                        ,*',arg-syms
+                                        ,',newval-sym)
+                          ,',newval-sym)))
+               ,body)))))
+
+  (deleter
+    (with-gensyms (osetter-sym ogetter-sym obj-sym oldval-sym)
+      (let ((arg-syms (mapcar (ret (gensym)) args)))
+        (if (place-form-p obj-place sys:*pl-env*)
+          (with-update-expander (ogetter-sym osetter-sym)
+                                ^(sys:l1-val ,obj-place) sys:*pl-env*
+            ^(macrolet ((,deleter ()
+                         ^(rlet ((,',obj-sym (,',ogetter-sym))
+                                 ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2)))
+                                           ',arg-syms ',args))
+                            (let ((,',oldval-sym [,',obj-sym ,*',arg-syms]))
+                              (progn
+                                (,',osetter-sym
+                                  (sys:dwim-del t ,',obj-sym ,*',arg-syms))
+                                ,',oldval-sym)))))
+                 ,body))
+            ^(macrolet ((,deleter ()
+                         ^(rlet ((,',obj-sym ,',obj-place)
+                                 ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2)))
+                                           ',arg-syms ',args))
+                            (let ((,',oldval-sym [,',obj-sym ,*',arg-syms]))
+                              (progn
+                                (sys:dwim-del nil ,',obj-sym ,*',arg-syms)
+                                ,',oldval-sym)))))
+                 ,body))))))
+
+(defplace (force promise) body
+  (getter setter
+    (with-gensyms (promise-sym)
+      ^(rlet ((,promise-sym ,promise))
+          (macrolet ((,getter ()
+                        ^(force ,',promise-sym))
+                     (,setter (val)
+                        ^(set (car (cdr ,',promise-sym)) ,val)))
+            ,body))))
+  (ssetter
+    (with-gensyms (promise-sym)
+      ^(rlet ((,promise-sym ,promise))
+         (macrolet ((,ssetter (val)
+                      ^(prog1
+                         (set (car (cdr ,',promise-sym)) ,val)
+                         (set (car ,',promise-sym) 'sys:promise-forced))))
+           ,body)))))
+
+(defplace (errno) body
+  (getter setter
+    ^(macrolet ((,getter () '(errno))
+                (,setter (val-expr)
+                   (with-gensyms (val-sym)
+                     ^(slet ((,val-sym ,val-expr))
+                         (progn (errno ,val-sym) ,val-sym)))))
+       ,body)))
+
+(defplace (fun sym) body
+  (getter setter
+    ^(macrolet ((,getter () ^(fun ,',sym))
+                (,setter (val) ^(sys:setqf ,',sym ,val)))
+       ,body))
+  nil
+  (deleter
+    ^(macrolet ((,deleter (:env env)
+                   (when (lexical-fun-p env ',sym)
+                     (compile-error ',sys:*pl-form*
+                                    "~s is a lexical function, \
+                                    \ thus not deletable"))
+                    ^(fmakunbound ',',sym)))
+       ,body)))
+
+(defun sys:get-fun-getter-setter (sym : f)
+  (tree-case sym
+    ((type struct slot)
+      (if (eq type 'meth)
+        (caseql slot
+          (:init (cons (op struct-get-initfun struct)
+                       (op struct-set-initfun struct)))
+          (:postinit (cons (op struct-get-postinitfun struct)
+                           (op struct-set-postinitfun struct)))
+          (t (cons (op static-slot struct slot)
+                   (op static-slot-ensure struct slot))))
+        :))
+    ((type sym)
+      (if (eq type 'macro)
+        (let ((cell (or (gethash sys:top-mb sym)
+                        (sethash sys:top-mb sym (cons sym nil)))))
+          (cons (op cdr)
+                (op sys:rplacd cell)))
+        :))
+    ((op . rest)
+     (if (eq op 'lambda)
+       (compile-error f "cannot assign to lambda")
+       (compile-error f "invalid function syntax ~s" sym)))
+    (else
+      (let ((cell (or (gethash sys:top-fb sym)
+                      (sethash sys:top-fb sym (cons sym nil)))))
+        (cons (op cdr)
+              (op sys:rplacd cell))))))
+
+(defplace (symbol-function sym-expr) body
+  (getter setter
+    (with-gensyms (gs-sym)
+      ^(let ((,gs-sym (sys:get-fun-getter-setter ,sym-expr ',sys:*pl-form*)))
+          (macrolet ((,getter () ^(call (car ,',gs-sym)))
+                     (,setter (val) ^(call (cdr ,',gs-sym) ,val)))
+            ,body))))
+  nil
+  (deleter
+    ^(macrolet ((,deleter () ^(fmakunbound ,',sym-expr)))
+       ,body)))
+
+(defun sys:get-mb (f sym)
+  (or (gethash sys:top-mb sym)
+      (compile-error f "unbound macro ~s" sym)))
+
+(defplace (symbol-macro sym-expr) body
+  (getter setter
+    (with-gensyms (binding-sym)
+      ^(let ((,binding-sym (sys:get-mb ',sys:*pl-form* ,sym-expr)))
+          (macrolet ((,getter () ^(cdr ,',binding-sym))
+                     (,setter (val) ^(sys:rplacd ,',binding-sym ,val)))
+            ,body))))
+  nil
+  (deleter
+    ^(macrolet ((,deleter () ^(mmakunbound ,',sym-expr)))
+       ,body)))
+
+(defun sys:get-vb (sym)
+  (or (gethash sys:top-vb sym)
+      (sethash sys:top-vb sym (cons sym nil))))
+
+(defplace (symbol-value sym-expr) body
+  (getter setter
+    (with-gensyms (binding-sym)
+      ^(let ((,binding-sym (sys:get-vb ,sym-expr)))
+          (macrolet ((,getter () ^(cdr ,',binding-sym))
+                     (,setter (val) ^(sys:rplacd ,',binding-sym ,val)))
+            ,body))))
+  nil
+  (deleter
+    ^(macrolet ((,deleter () ^(makunbound ,',sym-expr)))
+       ,body)))
+
+(defplace (slot struct sym) body
+  (getter setter
+    (with-gensyms (struct-sym slot-sym)
+      ^(alet ((,struct-sym ,struct)
+              (,slot-sym ,sym))
+         (macrolet ((,getter () ^(slot ,',struct-sym ,',slot-sym))
+                    (,setter (val) ^(slotset ,',struct-sym ,',slot-sym ,val)))
+           ,body))))
+  (ssetter
+    ^(macrolet ((,ssetter (val) ^(slotset ,',struct ,',sym ,val)))
+      ,body)))
+
+(defmacro define-modify-macro (name lambda-list function)
+  (let ((cleaned-lambda-list (mapcar [iffi consp car]
+                                     (remql : lambda-list))))
+    (with-gensyms (place-sym args-sym)
+      ^(defmacro ,name (:env env ,place-sym ,*lambda-list)
+         (with-update-expander (getter setter) ,place-sym env
+           ^(,setter (,',function (,getter) ,,*cleaned-lambda-list)))))))
+
+(defmacro sys:placelet-1 (((sym place)) :env env . body)
+  (with-gensyms (tmp-place pl-getter pl-setter)
+    (unwind-protect
+      (progn
+        ;; This temporary proxy place installed into the
+        ;; *place-update-expander* hash, and the forced expansion
+        ;; of the symacrolet form are necessary for correctness.
+        ;; If we don't perform that expand, then the temporary proxy
+        ;; place is not used, and sym ends up being an alias
+        ;; for the getter form (,',pl-getter) of the original place.
+        ;; Then, placelet will only work for places whose getter forms
+        ;; themselves places. This is not required in general. A (foo ...)
+        ;; place can, for instance, use (get-foo ...) and (set-foo ...)
+        ;; getters and setters, where (get-foo ...) is not a place.
+        ;; If sym turns into a symbol macro for a (get-foo ...) form,
+        ;; uses of sym as a place will fail due to get-foo not being a place.
+       (sethash *place-update-expander* tmp-place
+                 (lambda (tmp-getter tmp-setter tmp-place tmp-body)
+                   ^(macrolet ((,tmp-getter () ^(,',pl-getter))
+                               (,tmp-setter (val) ^(,',pl-setter ,val)))
+                      ,tmp-body)))
+        (call-update-expander pl-getter pl-setter place env
+          ^(macrolet ((,tmp-place () ^(,',pl-getter)))
+             ,(expand ^(symacrolet ((,sym (,tmp-place)))
+                         ,*body) env))))
+      (remhash *place-update-expander* tmp-place))))
+
+(defmacro placelet* (:form f sym-place-pairs . body)
+  (tree-case sym-place-pairs
+    (() ^(progn ,*body))
+    (((sym place)) ^(sys:placelet-1 ((,sym ,place)) ,*body))
+    (((sym place) . rest-pairs) ^(sys:placelet-1 ((,sym ,place))
+                                   (placelet* (,*rest-pairs) ,*body)))
+    (obj (compile-error f "bad syntax: ~s" obj))))
+
+(defmacro placelet (:form f sym-place-pairs . body)
+  (unless (all sym-place-pairs
+               [andf consp (opip length (= 2)) (oand first bindable)])
+    (compile-error f "bad syntax: ~s" sym-place-pairs))
+  (tree-bind (: syms places) (transpose sym-place-pairs)
+     (let ((temps (mapcar (ret (gensym)) syms)))
+       ^(placelet* (,*(zip temps places))
+          (symacrolet (,*(zip syms temps))
+            ,*body)))))
+
+(defun sys:register-simple-accessor (get-fun set-fun)
+  (sethash *place-update-expander* get-fun
+           (lambda (getter setter place body)
+             (let* ((args (cdr place))
+                    (temps (mapcar (ret (gensym)) args)))
+               ^(let (,(zip temps args))
+                  (macrolet ((,getter () ^(,',get-fun ,*',temps))
+                             (,setter (val)
+                               ^(,',set-fun ,*',temps ,val)))
+                    ,body)))))
+  (sethash *place-clobber-expander* get-fun
+           (lambda (ssetter place body)
+             ^(macrolet ((,ssetter (val)
+                               ^(,',set-fun ,*(cdr ',place) ,val)))
+                ,body)))
+  get-fun)
+
+(defmacro define-accessor (get-fun set-fun)
+  ^(sys:register-simple-accessor ',get-fun ',set-fun))
+
+(define-place-macro first (obj) ^(car ,obj))
+(define-place-macro rest (obj) ^(cdr ,obj))
+(define-place-macro second (obj) ^(ref ,obj 1))
+(define-place-macro third (obj) ^(ref ,obj 2))
+(define-place-macro fourth (obj) ^(ref ,obj 3))
+(define-place-macro fifth (obj) ^(ref ,obj 4))
+(define-place-macro sixth (obj) ^(ref ,obj 5))
+(define-place-macro seventh (obj) ^(ref ,obj 6))
+(define-place-macro eighth (obj) ^(ref ,obj 7))
+(define-place-macro ninth (obj) ^(ref ,obj 8))
+(define-place-macro tenth (obj) ^(ref ,obj 9))
+
+(define-place-macro last (:env e obj : (n nil have-n))
+  (cond
+    ((and have-n (constantp n e) (not (plusp n)))
+     ^(sub ,obj t t))
+    ((and have-n (constantp n e))
+     ^(sub ,obj ,(- n) t))
+    (have-n
+     ^(sub ,obj (- (max ,n 0)) t))
+    (t ^(sub ,obj -1 t))))
+
+(define-place-macro butlast (:env e obj : (n nil have-n))
+  (cond
+    ((and have-n (constantp n e) (not (plusp n)))
+     obj)
+    ((and have-n (constantp n e))
+     ^(sub ,obj 0 ,(- n)))
+    (have-n
+     ^(sub ,obj 0 (- (max ,n 0))))
+    (t ^(sub ,obj 0 -1))))
+
+(define-place-macro nth (index obj)
+  ^(car (nthcdr ,index ,obj)))