diff options
Diffstat (limited to 'stdlib/place.tl')
| -rw-r--r-- | stdlib/place.tl | 971 |
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))) |