diff options
Diffstat (limited to 'stdlib/defset.tl')
| -rw-r--r-- | stdlib/defset.tl | 130 |
1 files changed, 130 insertions, 0 deletions
diff --git a/stdlib/defset.tl b/stdlib/defset.tl new file mode 100644 index 00000000..15b44411 --- /dev/null +++ b/stdlib/defset.tl @@ -0,0 +1,130 @@ +;; Copyright 2019-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. + + +(compile-only + (load-for (struct sys:param-parser-base "param"))) + +(defun mac-env-flatten (env) + (when env + (let ((lexvars [mapcar car + [keep-if (op eq 'sys:special) + (env-vbindings env) cdr]])) + (append (mac-env-flatten (env-next env)) lexvars)))) + +(defun analyze-params (params) + (let* ((env (gensym)) + (lam ^(lambda ,params + (macrolet ((,env (:env e) + (set (symbol-value ',env) e))) + (,env)))) + (explam (expand lam)) + (syms (mac-env-flatten (symbol-value env)))) + (list (cadr explam) syms))) + +(defun defset-expander-simple (macform get-fun set-fun) + (with-gensyms (getter setter params) + ^(defplace (,get-fun . ,params) body + (,getter ,setter + (let ((pgens (mapcar (ret (gensym)) ,params))) + ^(alet ,(zip pgens (list ,*params)) + (macrolet ((,,getter () ^(,',',get-fun ,*',pgens)) + (,,setter (val) ^(,',',set-fun ,*',pgens ,val))) + ,body))))))) + +(defun defset-expander (env macform name params newval setform) + (with-gensyms (getter setter args gpf-pairs gpr-pairs ext-pairs + pgens rgens egens all-pairs agens nvsym) + (let* ((ap (analyze-params params)) + (exp-params (car ap)) + (total-syms (cadr ap)) + (fp (new fun-param-parser form macform syntax exp-params)) + (fixpars (append fp.req fp.(opt-syms))) + (restpar (if (symbol-package fp.rest) fp.rest)) + (extsyms [keep-if symbol-package + (diff total-syms (cons restpar fixpars))]) + (xsetform ^^(alet ((,',nvsym ,,newval)) + ,,(expand ^(symacrolet ((,newval ',nvsym)) + ,setform) + env)))) + ^(defplace (,name . ,args) body + (,getter ,setter + (tree-bind ,params ,args + (let* ((,gpf-pairs (mapcar (op (fun list) (gensym)) (list ,*fixpars))) + (,gpr-pairs (if ',restpar + (if (consp ,restpar) + (mapcar (op (fun list) (gensym)) ,restpar) + (list (list (gensym) ,restpar))))) + (,ext-pairs (mapcar (op (fun list) (gensym)) (list ,*extsyms))) + (,pgens (mapcar (fun car) ,gpf-pairs)) + (,rgens (mapcar (fun car) ,gpr-pairs)) + (,egens (mapcar (fun car) ,ext-pairs)) + (,all-pairs (append ,gpf-pairs ,gpr-pairs ,ext-pairs)) + (,agens (collect-each ((a ,args)) + (let ((p (pos a ,all-pairs (fun eq) (fun cadr)))) + (if p + (car (del [,all-pairs p])) + a))))) + ^(alet (,*,gpf-pairs ,*,gpr-pairs ,*,ext-pairs) + ,(expand ^(symacrolet (,*(zip ',fixpars + (mapcar (ret ^',@1) ,pgens)) + ,*(zip ',extsyms + (mapcar (ret ^',@1) ,egens)) + ,*(if ,gpr-pairs + (if (consp ,restpar) + ^((,',restpar ',,rgens)) + ^((,',restpar ',(car ,rgens)))))) + (macrolet ((,,getter () ^(,',',name ,',*,agens)) + (,,setter (,',newval) + ,',xsetform)) + ,body)) + ,env))))))))) + +(defmacro usr:defset (:env e :form mf . args) + (tree-case args + ((name (. params) newval setform) + (defset-expander e mf . args)) + ((get-fun set-fun) + (defset-expander-simple mf get-fun set-fun)) + (x (compile-error mf "invalid syntax")))) + +(defset sub-list (list : (from 0) (to t)) items + ^(progn (set ,list (replace-list ,list ,items ,from ,to)) ,items)) + +(defset sub-vec (vec : (from 0) (to t)) items + ^(progn (replace-vec ,vec ,items ,from ,to) ,items)) + +(defset sub-str (str : (from 0) (to t)) items + ^(progn (replace-str ,str ,items ,from ,to) ,items)) + +(defset left (node) nleft + ^(progn (set-left ,node ,nleft) ,nleft)) + +(defset right (node) nright + ^(progn (set-right ,node ,nright) ,nright)) + +(defset key (node) nkey + ^(progn (set-key ,node ,nkey) ,nkey)) |