diff options
author | Kaz Kylheku <kaz@kylheku.com> | 2021-06-24 07:21:38 -0700 |
---|---|---|
committer | Kaz Kylheku <kaz@kylheku.com> | 2021-06-24 07:21:38 -0700 |
commit | 2034729c70161b16d99eee0503c4354df39cd49d (patch) | |
tree | 400e7b2f7c67625e7ab6da3fe4a16c3257f30eb8 /stdlib/defset.tl | |
parent | 65f1445db0d677189ab01635906869bfda56d3d9 (diff) | |
download | txr-2034729c70161b16d99eee0503c4354df39cd49d.tar.gz txr-2034729c70161b16d99eee0503c4354df39cd49d.tar.bz2 txr-2034729c70161b16d99eee0503c4354df39cd49d.zip |
file layout: moving share/txr/stdlib to stdlib.
This affects run-time also. Txr installations where the
executable is not in directory ending in ${bindir}
will look for stdlib rather than share/txr/stdlib,
relative to the determined installation directory.
* txr.c (sysroot_init): If we detect relative to the short
name, or fall back on the program directory, use stdlib
rather than share/txr/stdlib as the stdlib_path.
* INSTALL: Update some installation notes not to refer to
share/txr/stdlib but stdlib.
* Makefile (STDLIB_SRCS): Refer to stdlib, not
share/txr/stdlib.
(clean): In unconfigured mode, remove the old share/txr/stdlib
entirely. Remove .tlo files from stdlib.
(install): Install lib materials from stdlib.
* txr.1: Updated documentation under Deployment Directory Structure.
* share/txr/stdlib/{asm,awk,build,cadr}.tl:
Renamed to stdlib/{asm,awk,build,cadr}.tl.
* share/txr/stdlib/{compiler,conv,copy-file,debugger}.tl:
Renamed to stdlib/{compiler,conv,copy-file,debugger}.tl.
* share/txr/stdlib/{defset,doc-lookup,doc-syms,doloop}.tl:
Renamed to stdlib/{defset,doc-lookup,doc-syms,doloop}.tl.
* share/txr/stdlib/{each-prod,error,except,ffi}.tl:
Renamed to stdlib/{each-prod,error,except,ffi}.tl.
* share/txr/stdlib/{getopts,getput,hash,ifa}.tl:
Renamed to stdlib/{getopts,getput,hash,ifa}.tl.
* share/txr/stdlib/{keyparams,match,op,optimize}.tl:
Renamed to stdlib/{keyparams,match,op,optimize}.tl.
* share/txr/stdlib/{package,param,path-test,pic}.tl:
Renamed to stdlib/{package,param,path-test,pic}.tl.
* share/txr/stdlib/{place,pmac,quips,save-exe}.tl:
Renamed to stdlib/{place,pmac,quips,save-exe}.tl.
* share/txr/stdlib/{socket,stream-wrap,struct,tagbody}.tl:
Renamed to stdlib/{socket,stream-wrap,struct,tagbody}.tl.
* share/txr/stdlib/{termios,trace,txr-case,type}.tl:
Renamed to stdlib/{termios,trace,txr-case,type}.tl.
* share/txr/stdlib/{ver,vm-param,with-resources,with-stream}.tl:
Renamed to stdlib/{ver,vm-param,with-resources,with-stream}.tl.
* share/txr/stdlib/yield.tl: Renamed to stdlib/yield.tl.
* share/txr/stdlib/{txr-case,ver}.txr:
Renamed to stdlib/{txr-case,ver}.txr.
* gencadr.txr: Update to stdlib/place.tl.
* genman.txr: Update to stdlib/cadr.tl.
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)) |