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.

1 files changed, 378 insertions, 0 deletions

diff --git a/stdlib/struct.tl b/stdlib/struct.tl
new file mode 100644
index 00000000..bd62637f
--- /dev/null
+++ b/stdlib/struct.tl
@@ -0,0 +1,378 @@
+;; 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.
+
+(defun sys:bad-slot-syntax (form arg)
+  (compile-error form "bad slot syntax ~s" arg))
+
+(defun sys:prune-missing-inits (slot-init-forms)
+  (remove-if (tb ((kind name : (init-form nil init-form-present)))
+               (and (member kind '(:static :instance :function))
+                    (not init-form-present)))
+             slot-init-forms))
+
+(defmacro defstruct (:form form name-spec super-spec . slot-specs)
+  (tree-bind (name args) (tree-case name-spec
+                           ((atom . args) (list atom args))
+                           (atom (list atom nil)))
+    (unless (bindable name)
+      (compile-error form "~s isn't a bindable symbol" name))
+    (unless (proper-listp slot-specs)
+      (compile-error form "bad syntax: dotted form"))
+    (let* ((instance-init-form nil)
+           (instance-postinit-form nil)
+           (instance-fini-form nil)
+           (slot-init-forms (collect-each ((slot slot-specs))
+                              (tree-case slot
+                                ((word name args . body)
+                                 (caseq word
+                                   (:method
+                                     (when (not args)
+                                       (compile-error form
+                                                      "method ~s needs \
+                                                      \ at least one parameter"
+                                                      name))
+                                     ^(:function ,name
+                                        (lambda ,args
+                                              (block ,name ,*body))))
+                                   (:function ^(,word ,name
+                                                 (lambda ,args
+                                                   (block ,name
+                                                     ,*body))))
+                                   ((:static :instance)
+                                     (when body
+                                       (sys:bad-slot-syntax form slot))
+                                     ^(,word ,name ,args))
+                                   (t :)))
+                                ((word (arg) . body)
+                                 (caseq word
+                                   (:init
+                                     (unless (bindable arg)
+                                       (sys:bad-slot-syntax form slot))
+                                     (when instance-init-form
+                                       (compile-error form
+                                                      "duplicate :init"))
+                                     (set instance-init-form
+                                          (cons arg body))
+                                     ^(,word nil nil))
+                                   (:postinit
+                                     (unless (bindable arg)
+                                       (sys:bad-slot-syntax form slot))
+                                     (when instance-postinit-form
+                                       (compile-error form
+                                                      "duplicate :postinit"))
+                                     (set instance-postinit-form
+                                          (cons arg body))
+                                     ^(,word nil nil))
+                                   (:fini
+                                     (unless (bindable arg)
+                                       (sys:bad-slot-syntax form slot))
+                                     (when instance-fini-form
+                                       (compile-error form
+                                                      "duplicate :fini"))
+                                     (set instance-fini-form
+                                          (cons arg body))
+                                     ^(,word nil nil))
+                                   (t (when body
+                                        (sys:bad-slot-syntax form slot))
+                                      :)))
+                                ((word name)
+                                   (caseq word
+                                     ((:static)
+                                      ^(,word ,name))
+                                     ((:instance)
+                                      ^(,word ,name nil))
+                                     ((:method :function)
+                                      (sys:bad-slot-syntax form slot))
+                                     (t ^(:instance ,word ,name))))
+                                ((name)
+                                  ^(:instance ,name nil))
+                                (name
+                                  ^(:instance ,name nil)))))
+           (supers (if (and super-spec (atom super-spec))
+                     (list super-spec)
+                     super-spec))
+           (stat-si-forms [keep-if (op member @1 '(:static :function))
+                                   slot-init-forms car])
+           (pruned-si-forms (sys:prune-missing-inits stat-si-forms))
+           (func-si-forms [keep-if (op eq :function) pruned-si-forms car])
+           (val-si-forms [keep-if (op eq :static) pruned-si-forms car])
+           (inst-si-forms [keep-if (op eq :instance) slot-init-forms car])
+           (stat-slots [mapcar second stat-si-forms])
+           (inst-slots [mapcar second inst-si-forms]))
+      (whenlet ((bad [find-if [notf bindable]
+                              (append stat-slots inst-slots)]))
+        (compile-error form
+                       (if (symbolp bad)
+                         "slot name ~s isn't a bindable symbol"
+                         "invalid slot specifier syntax: ~s")
+                       bad))
+      (each ((s supers))
+        (or (find-struct-type s)
+            (compile-defr-warning form ^(struct-type . ,s)
+                                  "inheritance base ~s \
+                                  \ does not name a struct type"
+                                  s)))
+      (let ((arg-sym (gensym))
+            (type-sym (gensym)))
+        (register-tentative-def ^(struct-type . ,name))
+        (each ((s stat-slots))
+          (register-tentative-def ^(slot . ,s)))
+        (each ((s inst-slots))
+          (register-tentative-def ^(slot . ,s)))
+        ^(sys:make-struct-type
+           ',name ',supers ',stat-slots ',inst-slots
+           ,(if (or func-si-forms val-si-forms)
+               ^(lambda (,arg-sym)
+                  ,*(mapcar (aret ^(when (static-slot-p ,arg-sym ',@2)
+                                     (static-slot-set ,arg-sym ',@2 ,@3)))
+                            (append func-si-forms val-si-forms))))
+           ,(if (or inst-si-forms instance-init-form instance-fini-form)
+              ^(lambda (,arg-sym)
+                 ,*(if (cdr instance-fini-form)
+                     ^((finalize ,arg-sym (lambda (,(car instance-fini-form))
+                                            ,*(cdr instance-fini-form))
+                                 t)))
+                 ,*(if inst-si-forms
+                     ^((let ((,type-sym (struct-type ,arg-sym)))
+                         ,*(mapcar (aret ^(unless (static-slot-p ,type-sym ',@2)
+                                            (slotset ,arg-sym ',@2 ,@3)))
+                                   inst-si-forms))))
+                 ,*(if (cdr instance-init-form)
+                     ^((let ((,(car instance-init-form) ,arg-sym))
+                         ,*(cdr instance-init-form))))))
+           ,(when args
+              (when (> (countql : args) 1)
+                (compile-error form
+                               "multiple colons in boa syntax"))
+              (let ((col-pos (posq : args)))
+                (let ((req-args [args 0..col-pos])
+                      (opt-args (if col-pos [args (succ col-pos)..:])))
+                  (let ((r-gens (mapcar (ret (gensym)) req-args))
+                        (o-gens (mapcar (ret (gensym)) opt-args))
+                        (p-gens (mapcar (ret (gensym)) opt-args)))
+                    ^(lambda (,arg-sym ,*r-gens
+                              ,*(if opt-args '(:))
+                              ,*(if opt-args
+                                  (mapcar (ret ^(,@1 nil ,@2))
+                                          o-gens p-gens)))
+                       ,*(mapcar (ret ^(slotset ,arg-sym ',@1 ,@2))
+                                 req-args r-gens)
+                       ,*(mapcar (ret ^(if ,@3
+                                         (slotset ,arg-sym ',@1 ,@2)))
+                                 opt-args o-gens p-gens))))))
+           ,(if instance-postinit-form
+              ^(lambda (,arg-sym)
+                 ,*(if (cdr instance-postinit-form)
+                     ^((let ((,(car instance-postinit-form) ,arg-sym))
+                         ,*(cdr instance-postinit-form)))))))))))
+
+(defmacro sys:struct-lit (name . plist)
+  ^(sys:make-struct-lit ',name ',plist))
+
+(defun sys:check-slot (form slot)
+  (unless (or (sys:slot-types slot)
+              (sys:static-slot-types slot))
+    (compile-defr-warning form ^(slot . ,slot)
+                          "symbol ~s isn't the name of a struct slot"
+                          slot))
+  slot)
+
+(defun sys:check-struct (form stype)
+  (unless (find-struct-type stype)
+    (compile-defr-warning form ^(struct-type . ,stype)
+                          "~s does not name a struct type"
+                          stype)))
+
+(defmacro qref (:form form obj . refs)
+  (when (null refs)
+    (throwf 'eval-error "~s: bad syntax" 'qref))
+  (tree-case obj
+    ((a b) (if (eq a 't)
+             (let ((s (gensym)))
+               ^(slet ((,s ,b))
+                  (if ,s (qref ,s ,*refs))))
+             :))
+    (x (tree-case refs
+         (() ())
+         (((pref sym) . more)
+           (if (eq pref t)
+             (let ((s (gensym)))
+               ^(let ((,s (qref ,obj ,sym)))
+                  (if ,s (qref ,s ,*more))))
+             :))
+         (((dw sym . args))
+          (if (eq dw 'dwim)
+            (let ((osym (gensym)))
+              (sys:check-slot form sym)
+              ^(slet ((,osym ,obj))
+                 ,(if (and (plusp sys:compat) (<= sys:compat 251))
+                    ^[(slot ,osym ',sym) ,*args]
+                    ^[(slot ,osym ',sym) ,osym ,*args])))
+            :))
+         (((dw sym . args) . more)
+          (if (eq dw 'dwim)
+            (let ((osym (gensym)))
+              (sys:check-slot form sym)
+              ^(qref (slet ((,osym ,obj))
+                       ,(if (and (plusp sys:compat) (<= sys:compat 251))
+                          ^[(slot ,osym ',sym) ,*args]
+                          ^[(slot ,osym ',sym) ,osym ,*args])) ,*more))
+            :))
+         (((sym . args))
+          (let ((osym (gensym)))
+            (sys:check-slot form sym)
+            ^(slet ((,osym ,obj))
+               (call (slot ,osym ',sym) ,osym ,*args))))
+         (((sym . args) . more)
+          (let ((osym (gensym)))
+            (sys:check-slot form sym)
+            ^(qref (slet ((,osym ,obj))
+                     (call (slot ,osym ',sym) ,osym ,*args)) ,*more)))
+         ((sym)
+          (sys:check-slot form sym)
+          ^(slot ,obj ',sym))
+         ((sym . more)
+          (sys:check-slot form sym)
+          ^(qref (slot ,obj ',sym) ,*more))
+         (obj (throwf 'eval-error "~s: bad syntax: ~s" 'qref refs))))))
+
+(defmacro uref (. args)
+  (cond
+    ((null args) (throwf 'eval-error "~s: bad syntax" 'uref))
+    ((null (cdr args))
+     (if (consp (car args))
+       ^(umeth ,*(car args))
+       ^(usl ,(car args))))
+    ((eq t (car args))
+     (with-gensyms (ovar)
+       ^(lambda (,ovar) (qref (t ,ovar) ,*(cdr args)))))
+    (t (with-gensyms (ovar)
+         ^(lambda (,ovar) (qref ,ovar ,*args))))))
+
+(defun sys:new-type (op form type)
+  (caseq op
+    ((new lnew) (sys:check-struct form type) ^',type)
+    (t type)))
+
+(defun sys:new-expander (op form spec pairs)
+  (when (oddp (length pairs))
+    (compile-error form "slot initform arguments must occur pairwise"))
+  (let ((qpairs (mappend (aret ^(',@1 ,@2)) (tuples 2 pairs))))
+    (tree-case spec
+      ((texpr . args)
+       (let ((type (sys:new-type op form texpr)))
+         (caseq op
+           ((new new*) (if qpairs
+                         ^(make-struct ,type (list ,*qpairs) ,*args)
+                         ^(struct-from-args ,type ,*args)))
+           ((lnew lnew*) ^(make-lazy-struct ,type
+                                            (lambda ()
+                                              (cons (list ,*qpairs)
+                                                    (list ,*args))))))))
+      (texpr
+        (let ((type (sys:new-type op form texpr)))
+          (caseq op
+            ((new new*) ^(struct-from-plist ,type ,*qpairs))
+            ((lnew lnew*) ^(make-lazy-struct ,type
+                                             (lambda ()
+                                               (list (list ,*qpairs)))))))))))
+
+(defmacro new (:form form spec . pairs)
+  (sys:new-expander (car form) form spec pairs))
+
+(defmacro new* (:form form spec . pairs)
+  (sys:new-expander (car form) form spec pairs))
+
+(defmacro lnew (:form form spec . pairs)
+  (sys:new-expander (car form) form spec pairs))
+
+(defmacro lnew* (:form form spec . pairs)
+  (sys:new-expander (car form) form spec pairs))
+
+(defmacro meth (obj slot . bound-args)
+  ^[(fun method) ,obj ',slot ,*bound-args])
+
+(defmacro usl (:form form slot)
+  (sys:check-slot form slot)
+  ^(uslot ',slot))
+
+(defmacro umeth (:form form slot . bound-args)
+  (sys:check-slot form slot)
+  ^[(fun umethod) ',slot ,*bound-args])
+
+(defun sys:define-method (type-sym name fun)
+  (caseq name
+    (:init (struct-set-initfun type-sym fun))
+    (:postinit (struct-set-postinitfun type-sym fun))
+    (t (static-slot-ensure type-sym name fun)))
+  ^(meth ,type-sym ,name))
+
+(defmacro defmeth (:form form type-sym name arglist . body)
+  (cond
+    ((not (bindable type-sym))
+      (compile-error form "~s isn't a valid struct name" type-sym))
+    ((not (find-struct-type type-sym))
+      (compile-defr-warning form ^(struct-type . ,type-sym)
+                            "definition of struct ~s not seen here" type-sym)))
+  (register-tentative-def ^(slot . ,name))
+  ^(sys:define-method ',type-sym ',name (lambda ,arglist
+                                          (block ,name ,*body))))
+
+(defmacro with-slots ((. slot-specs) obj-expr . body)
+  (with-gensyms (obj-sym)
+    ^(let ((,obj-sym ,obj-expr))
+       (symacrolet (,*(mapcar [iff consp
+                                   (aret ^(,@1 (slot ,obj-sym ',@2)))
+                                   (ret ^(,@1 (slot ,obj-sym ',@1)))]
+                              slot-specs))
+         ,*body))))
+
+(defun sys:rslotset (struct sym meth-sym val)
+  (prog1
+    (slotset struct sym val)
+    (call (umethod meth-sym) struct)))
+
+(defmacro usr:rslot (struct sym meth-sym)
+  ^(slot ,struct ,sym))
+
+(define-place-macro usr:rslot (struct sym meth-sym)
+  ^(sys:rslot ,struct ,sym ,meth-sym))
+
+(defplace (sys:rslot struct sym meth-sym) body
+  (getter setter
+    (with-gensyms (struct-sym slot-sym meth-slot-sym)
+      ^(slet ((,struct-sym ,struct)
+              (,slot-sym ,sym)
+              (,meth-slot-sym ,meth-sym))
+         (macrolet ((,getter () ^(slot ,',struct-sym ,',slot-sym))
+                    (,setter (val) ^(sys:rslotset ,',struct-sym ,',slot-sym
+                                                  ,',meth-slot-sym ,val)))
+           ,body))))
+  (ssetter
+    ^(macrolet ((,ssetter (val) ^(progn
+                                   (sys:rslotset ,',struct ,',sym
+                                             ,',meth-sym ,val))))
+       ,body)))