diff options
Diffstat (limited to 'share/txr/stdlib/place.tl')
| -rw-r--r-- | share/txr/stdlib/place.tl | 970 |
1 files changed, 0 insertions, 970 deletions
diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl deleted file mode 100644 index 4e2c7904..00000000 --- a/share/txr/stdlib/place.tl +++ /dev/null @@ -1,970 +0,0 @@ -;; Copyright 2015-2020 -;; 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) - (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))) |