diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | genvim.txr | 2 | ||||
| -rw-r--r-- | share/txr/stdlib/place.tl | 1053 |
3 files changed, 534 insertions, 528 deletions
@@ -1,3 +1,10 @@ +2015-06-22 Kaz Kylheku <kaz@kylheku.com> + + * share/txr/stdlib/place.tl: Get rid of big progn around the + whole module. + + * genvim.txr: Handle (def's not preceded by spaces. + 2015-06-21 Kaz Kylheku <kaz@kylheku.com> Version 109. @@ -32,7 +32,7 @@ static void dir_tables_init(void) @ (or) @/ */reg_var(@(skip)intern(lit("@{txl-sym}")@(skip) @ (or) - (@/defun|defvar|defmacro/ @{txl-sym} @(skip) +@/ *\((defun|defvar|defmacro)/ @{txl-sym} @(skip) @ (end) @ (set txl-sym @(regsub #/_/ #\- txl-sym)) @ (end) diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl index 83c2d813..9bb39347 100644 --- a/share/txr/stdlib/place.tl +++ b/share/txr/stdlib/place.tl @@ -23,535 +23,534 @@ ;; 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)) - (defvar sys:*lisp1* nil) - - (defun sys:eval-err (. params) - (throwf 'eval-error . params)) - - (defmacro sys:l1-setq (sym new-val :env e) - (caseq (lexical-lisp1-binding e sym) - (:var ^(sys:setq ,sym ,new-val)) - (:symacro (sys:eval-err "sys:l1-setq: invalid use on symbol macro")) - (t (if (boundp sym) - ^(sys:setq ,sym ,new-val) - ^(sys:lisp1-setq ,sym ,new-val))))) - - (defmacro sys:l1-val (u-expr :env e) - (let ((e-expr (macroexpand u-expr e))) - (if (and (symbolp e-expr) (not (constantp e-expr))) - (caseq (lexical-lisp1-binding e e-expr) - (:fun ^(fun ,u-expr)) - (:var u-expr) - (nil (if (boundp e-expr) - u-expr - ^(sys:lisp1-value ,u-expr))) - (t (sys:eval-err "sys:l1-val: invalid case"))) - u-expr))) - - (defun sys:sym-update-expander (getter-name setter-name - place-expr op-body) - (if sys:*lisp1* - ^(macrolet ((,getter-name () ^(sys:l1-val ,',place-expr)) - (,setter-name (val-expr) ^(sys:l1-setq ,',place-expr - ,val-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) - ^(,(if sys:*lisp1* 'sys:l1-setq '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 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))))) - - (defmacro rlet (bindings :env e . body) - (let ((exp-bindings (mapcar (aret ^(,@1 ,(macroexpand @2 e))) bindings))) - (let ((renames [keep-if constantp exp-bindings second]) - (regular [remove-if 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 (: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 ^(let (,*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 :env env) +(macro-time + (defvar *place-clobber-expander* (hash)) + (defvar *place-update-expander* (hash)) + (defvar *place-delete-expander* (hash)) + (defvar sys:*lisp1* nil) + + (defun sys:eval-err (. params) + (throwf 'eval-error . params)) + + (defmacro sys:l1-setq (sym new-val :env e) + (caseq (lexical-lisp1-binding e sym) + (:var ^(sys:setq ,sym ,new-val)) + (:symacro (sys:eval-err "sys:l1-setq: invalid use on symbol macro")) + (t (if (boundp sym) + ^(sys:setq ,sym ,new-val) + ^(sys:lisp1-setq ,sym ,new-val))))) + + (defmacro sys:l1-val (u-expr :env e) + (let ((e-expr (macroexpand u-expr e))) + (if (and (symbolp e-expr) (not (constantp e-expr))) + (caseq (lexical-lisp1-binding e e-expr) + (:fun ^(fun ,u-expr)) + (:var u-expr) + (nil (if (boundp e-expr) + u-expr + ^(sys:lisp1-value ,u-expr))) + (t (sys:eval-err "sys:l1-val: invalid case"))) + u-expr))) + + (defun sys:sym-update-expander (getter-name setter-name + place-expr op-body) + (if sys:*lisp1* + ^(macrolet ((,getter-name () ^(sys:l1-val ,',place-expr)) + (,setter-name (val-expr) ^(sys:l1-setq ,',place-expr + ,val-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) + ^(,(if sys:*lisp1* 'sys:l1-setq '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 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))))) + +(defmacro rlet (bindings :env e . body) + (let ((exp-bindings (mapcar (aret ^(,@1 ,(macroexpand @2 e))) bindings))) + (let ((renames [keep-if constantp exp-bindings second]) + (regular [remove-if 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 (: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 ^(let (,*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 :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-gensyms (new-sym) + ^(let ((,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 - ^(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-gensyms (new-sym) - ^(let ((,new-sym ,new-item)) + ^(let ((,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) + ^(let ((,new-item-sym ,new-item)) ,(with-update-expander (getter setter) place env - ^(,setter (cons ,new-sym (,getter))))))) - - (defmacro pop (place :env env) - (with-gensyms (tmp) + ^(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 (: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 - ^(let ((,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) - ^(let ((,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 (: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))) + ^(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) ^(sys:rplaca ,',cell ,val))) + (ssetter + ^(macrolet ((,ssetter (val) ^(refset ,*',args ,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) :env env) body - (getter setter - (with-gensyms (ogetter-sym osetter-sym obj-sym - oldval-sym newval-sym - index-sym index-sym - oldval-sym dflval-sym) - (let ((sys:*lisp1* (or (symbolp obj-place) sys:*lisp1*))) - (with-update-expander (ogetter-sym osetter-sym) obj-place nil - ^(rlet ((,obj-sym (,ogetter-sym)) - (,index-sym (sys:l1-val ,index)) - ,*(if have-default-p - ^((,dflval-sym (sys:l1-val ,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) - (let ((sys:*lisp1* (or (symbolp obj-place) sys:*lisp1*))) - (with-update-expander (ogetter-sym osetter-sym) obj-place nil - ^(macrolet ((,ssetter (val) - ^(rlet ((,',obj-sym (,',ogetter-sym)) - (,',index-sym (sys:l1-val ,',index)) - (,',newval-sym ,val)) - (,',osetter-sym - (sys:dwim-set ,',obj-sym - ,*(if ,have-default-p - ^((prog1 - ,',index-sym - (sys:l1-val ,',default))) - ^(,',index-sym)) - ,',newval-sym)) - ,',newval-sym))) - ,body))))) - - (deleter - (with-gensyms (osetter-sym ogetter-sym - obj-sym index-sym oldval-sym - dflval-sym) - (let ((sys:*lisp1* (or (symbolp obj-place) sys:*lisp1*))) - (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 (sys:l1-val ,',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))) - - (defplace (fun sym) body - (getter setter - ^(macrolet ((,getter () ^(fun ,',sym)) - (,setter (val) ^(sys:setqf ,',sym ,val))) - ,*body)) - : - (deleter - ^(macrolet ((,deleter (:env env) - (when (lexical-fun-p env ',sym) - (sys:eval-err "~s is a lexical function, \ - \ thus not deletable" - ',sym)) - ^(fmakunbound ',',sym))) - ,*body))) - - (defun sys:get-fb (sym) - (or (gethash sys:top-fb sym) - (sys:eval-err "unbound function ~s" sym))) - - (defplace (symbol-function sym-expr) body - (getter setter - (with-gensyms (binding-sym) - ^(let ((,binding-sym (sys:get-fb ,sym-expr))) - (macrolet ((,getter () ^(cdr ,',binding-sym)) - (,setter (val) ^(sys:rplacd ,',binding-sym ,val))) - ,*body)))) - : - (deleter - ^(macrolet ((,deleter () ^(fmakunbound ,',sym-expr))) - ,*body))) - - (defun sys:get-vb (sym) - (or (gethash sys:top-vb sym) - (sys:eval-err "unbound variable ~s" sym))) - - (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)))) - : - (deleter - ^(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)))) - (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)))))))) + (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) :env env) body + (getter setter + (with-gensyms (ogetter-sym osetter-sym obj-sym + oldval-sym newval-sym + index-sym index-sym + oldval-sym dflval-sym) + (let ((sys:*lisp1* (or (symbolp obj-place) sys:*lisp1*))) + (with-update-expander (ogetter-sym osetter-sym) obj-place nil + ^(rlet ((,obj-sym (,ogetter-sym)) + (,index-sym (sys:l1-val ,index)) + ,*(if have-default-p + ^((,dflval-sym (sys:l1-val ,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) + (let ((sys:*lisp1* (or (symbolp obj-place) sys:*lisp1*))) + (with-update-expander (ogetter-sym osetter-sym) obj-place nil + ^(macrolet ((,ssetter (val) + ^(rlet ((,',obj-sym (,',ogetter-sym)) + (,',index-sym (sys:l1-val ,',index)) + (,',newval-sym ,val)) + (,',osetter-sym + (sys:dwim-set ,',obj-sym + ,*(if ,have-default-p + ^((prog1 + ,',index-sym + (sys:l1-val ,',default))) + ^(,',index-sym)) + ,',newval-sym)) + ,',newval-sym))) + ,body))))) + + (deleter + (with-gensyms (osetter-sym ogetter-sym + obj-sym index-sym oldval-sym + dflval-sym) + (let ((sys:*lisp1* (or (symbolp obj-place) sys:*lisp1*))) + (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 (sys:l1-val ,',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))) + +(defplace (fun sym) body + (getter setter + ^(macrolet ((,getter () ^(fun ,',sym)) + (,setter (val) ^(sys:setqf ,',sym ,val))) + ,*body)) + : + (deleter + ^(macrolet ((,deleter (:env env) + (when (lexical-fun-p env ',sym) + (sys:eval-err "~s is a lexical function, \ + \ thus not deletable" + ',sym)) + ^(fmakunbound ',',sym))) + ,*body))) + +(defun sys:get-fb (sym) + (or (gethash sys:top-fb sym) + (sys:eval-err "unbound function ~s" sym))) + +(defplace (symbol-function sym-expr) body + (getter setter + (with-gensyms (binding-sym) + ^(let ((,binding-sym (sys:get-fb ,sym-expr))) + (macrolet ((,getter () ^(cdr ,',binding-sym)) + (,setter (val) ^(sys:rplacd ,',binding-sym ,val))) + ,*body)))) + : + (deleter + ^(macrolet ((,deleter () ^(fmakunbound ,',sym-expr))) + ,*body))) + +(defun sys:get-vb (sym) + (or (gethash sys:top-vb sym) + (sys:eval-err "unbound variable ~s" sym))) + +(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)))) + : + (deleter + ^(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)))) + (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))))))) |