New macro-based framework for assignment places.

The operators set, inc, dec, pop and others are now macros
which generate code, rather than built-in special forms
that use "C magic".  Moreover, new such macros are easy to write, and
several new ones are already available.  Moreover, new kinds of
assignable places are easy to create.

* place.tl: New file.

* lisplib.c, lisplib.h: New files.

* Makefile (OBJS): New target, lisplib.o.
(GEN_HDRS): New variable.
(LISP_TO_C_STRING): New recipe macro, with rule.
(clean): Remove generated headers named in $(GEN_HDRS).

* eval.c (dec_s, push_s, pop_s, flip_s, del_s): Variables removed.
(setq_s): New variable.
(lookup_var, lokup_sym_lisp_1, lookup_var_l, lookup_fun, lookup_mac,
lookup_symac, lookup_symac_lisp1): Trigger the delayed loading of
libraries for undefined global symbols, and re-try the lookup.
(op_modplace, dwim_loc, force_l): Static functions removed.
(op_setq): New static function.
(eval_init): Initialize setq_s; remove initializations of
removed variables; remove registrations for op_modplace;
add registration for sys:setq, sys:rplaca, sys:rplacd,
sys:dwim-set and sys:dwim-del intrinsics.
Call lisplib_init to initialize the dynamic library loading module.

* lib.c (sys_rplaca, sys_rplacd): New functions, differing
in return value from rplaca and rplacd.
(ref, refset): Handle hash table.
(dwim_set, dwim_del): New functions.

* lib.h (sys_rplaca, sys_rplacd, dwim_set, dwim_del): Declared.

* genvim.txr: Include place.tl in scan.

* tests/010/seq.txr: The del operator test
case no longer throws at run-time but at macro-expansion time, so the
test case is simply removed.

* tests/010/seq.expected: Updated output.

* tests/011/macros-2.txr: Reset *gensym-counter* to zero, because
the textual output of the test case includes gensyms, whose numberings
fluctuate with the content of the new Lisp library material.

* tests/011/macros-2.expected: Updated output.

1 files changed, 416 insertions, 0 deletions

diff --git a/place.tl b/place.tl
new file mode 100644
index 00000000..d74b1f62
--- /dev/null
+++ b/place.tl
@@ -0,0 +1,416 @@
+;; Copyright 2015
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution of this software in source and binary forms, with or without
+;; modification, is permitted provided that the following two conditions are met.
+;;
+;; Use of this software in any manner constitutes agreement with the disclaimer
+;; which follows the two conditions.
+;;
+;; 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 ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
+;; WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
+;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  IN NO EVENT SHALL THE
+;; COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DAMAGES, HOWEVER CAUSED,
+;; AND UNDER ANY THEORY OF LIABILITY, ARISING IN ANY WAY OUT OF THE USE OF THIS
+;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+(progn
+  (macro-time
+    (defvar *place-clobber-expander* (hash))
+    (defvar *place-update-expander* (hash))
+    (defvar *place-delete-expander* (hash))
+
+    (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 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)
+      (if (consp place)
+        (or [*place-delete-expander* (car place)]
+            (sys:eval-err "~s is not a deletable place" place))
+        (sys:eval-err "form ~s is not syntax denoting a deletable place" place))))
+
+  (defmacro rlet (bindings :env e . body)
+    (let ((exp-bindings (mapcar (aret ^(,@1 ,(macroexpand @2 e))) bindings)))
+      (let ((renames [keep-if [orf symbolp constantp] exp-bindings second])
+            (regular [remove-if [orf symbolp constantp] exp-bindings second]))
+        (cond ((and renames regular)
+                ^(symacrolet ,renames
+                   (let ,regular ,*body)))
+              (renames ^(symacrolet ,renames ,*body))
+              (regular ^(let ,regular ,*body))
+              (t ^(progn ,*body))))))
+
+  (defmacro with-gensyms (syms . body)
+    ^(let ,(zip syms (repeat '((gensym)))) ,*body))
+
+  (macro-time
+    (defun call-update-expander (getter setter unex-place env . body)
+      (let* ((place (sys: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))
+             (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))
+             (expander (get-delete-expander place)))
+        [expander deleter place . body])))
+
+  (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 (place value :env env)
+    (with-clobber-expander (ssetter) place env
+      ^(,ssetter ,value)))
+
+  (defmacro zap (place :env env)
+    (with-update-expander (getter setter) place env
+      ^(prog1 (,getter) (,setter nil))))
+
+  (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 ^(,setter (,getter)))
+        (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 ^(,setter (,getter)))
+        (1 ^(,setter (pred (,getter))))
+        (2 ^(,setter (ppred (,getter))))
+        (3 ^(,setter (pppred (,getter))))
+        (t ^(,setter (- (,getter) ,delta))))))
+
+  (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-update-expander (getter setter) place env
+      ^(,setter (cons ,new-item (,getter)))))
+
+  (defmacro pop (place :env env)
+    (with-gensyms (tmp)
+      (with-update-expander (getter setter) place env
+        ^(let ((,tmp (,getter)))
+           (prog1 (car ,tmp) (,setter (cdr ,tmp)))))))
+
+  (defmacro shift (:env env . places)
+    (tree-case places
+      (() (sys:eval-err "shift: need at least two arguments"))
+      ((place) (sys:eval-err "shift: 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 del (place :env env)
+    (with-delete-expander (deleter) place env
+      ^(,deleter)))
+
+  (defmacro defplace (place-destructuring-args body-sym
+                      (getter-sym setter-sym . update-body) :
+                      ((ssetter-sym . clobber-body))
+                      ((deleter-sym . delete-body)))
+    (symacrolet ((name (car place-destructuring-args))
+                 (args (cdr place-destructuring-args)))
+      (unless (and name
+                   (symbolp name)
+                   (not (keywordp name))
+                   (not (eq t name)))
+        (sys:eval-err "~s: ~s cannot be used as a place name"
+                  'defplace name))
+      (with-gensyms (place)
+        ^(macro-time
+           (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)))))))))
+
+  (defplace (car cell) body
+    (getter setter
+      (with-gensyms (cell-sym)
+        ^(rlet ((,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)
+        ^(rlet ((,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 () ^(zap (cdr ,',cell))))
+         ,*body)))
+
+   (defplace (vecref vector index :whole args) body
+     (getter setter
+       (with-gensyms (vec-sym ind-sym)
+         ^(rlet ((,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)
+         ^(rlet ((,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)
+         ^(rlet ((,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)
+         ^(rlet ((,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)
+         ^(rlet ((,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)
+         ^(rlet ((,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 (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))))
+     :
+     (deleter
+       ^(macrolet ((,deleter ()
+                     (if ,have-default-p
+                       (with-gensyms (entry-sym
+                                      dfl-sym)
+                         ^(rlet ((,entry-sym (inhash ,',hash ,',key))
+                                 (,dfl-sym ,',default))
+                            (if ,entry-sym
+                              (remhash ,',hash ,',key)
+                              ,dfl-sym)))
+                       ^(remhash ,',hash ,',key))))
+          ,*body)))
+
+   (defplace (dwim obj-place index : (default nil have-default-p)) body
+     (getter setter
+       (with-gensyms (ogetter-sym osetter-sym obj-sym
+                      oldval-sym newval-sym
+                      index-sym index-sym
+                      oldval-sym dflval-sym)
+         (with-update-expander (ogetter-sym osetter-sym) obj-place nil
+           ^(rlet ((,obj-sym (,ogetter-sym))
+                   (,index-sym ,index)
+                   ,*(if have-default-p
+                       ^((,dflval-sym ,default))))
+              (let ((,oldval-sym [,obj-sym
+                                 ,index-sym
+                                 ,*(if have-default-p ^(,dflval-sym))]))
+                (macrolet ((,getter () ',oldval-sym)
+                           (,setter (val)
+                              ^(rlet ((,',newval-sym ,val))
+                                 (,',osetter-sym
+                                   (sys:dwim-set ,',obj-sym
+                                                 ,',index-sym ,',newval-sym))
+                                 ,',newval-sym)))
+                   ,*body))))))
+     (ssetter
+       (with-gensyms (osetter-sym ogetter-sym
+                      obj-sym newval-sym index-sym)
+         (with-update-expander (ogetter-sym osetter-sym) obj-place nil
+           ^(macrolet ((,ssetter (val)
+                        ^(rlet ((,',obj-sym (,',ogetter-sym))
+                                (,',index-sym ,',index)
+                                (,',newval-sym ,val))
+                           (,',osetter-sym
+                             (sys:dwim-set ,',obj-sym
+                                           ,*(if ,have-default-p
+                                               ^((prog1 ,',index-sym ,',default))
+                                               ^(,',index-sym))
+                                           ,',newval-sym))
+                           ,',newval-sym)))
+                ,*body))))
+
+     (deleter
+       (with-gensyms (osetter-sym ogetter-sym
+                      obj-sym index-sym oldval-sym
+                      dflval-sym)
+         (with-update-expander (ogetter-sym osetter-sym) obj-place nil
+           ^(macrolet ((,deleter ()  ;; todo: place must not have optional val
+                        ^(rlet ((,',obj-sym (,',ogetter-sym)))
+                           (let* ((,',index-sym ,',index)
+                                  (,',oldval-sym [,',obj-sym
+                                                  ,',index-sym
+                                                  ,*(if ,have-default-p
+                                                      ^(,',default))]))
+                             (progn
+                               (,',osetter-sym
+                                 (sys:dwim-del ,',obj-sym ,',index-sym))
+                               ,',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)
+                        ^(rlet ((,val-sym ,val-expr))
+                            (progn (errno ,val-sym) ,val-sym)))))
+          ,*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])))))