diff options
Diffstat (limited to 'stdlib/build.tl')
-rw-r--r-- | stdlib/build.tl | 149 |
1 files changed, 149 insertions, 0 deletions
diff --git a/stdlib/build.tl b/stdlib/build.tl new file mode 100644 index 00000000..35f71a7c --- /dev/null +++ b/stdlib/build.tl @@ -0,0 +1,149 @@ +;; Copyright 2016-2024 +;; 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:list-builder-flets (lb-form) + (nconc + (collect-each ((op '(add add* pend pend* ncon ncon* oust))) + ^(,op (. args) + (qref ,lb-form (,op . args)) + nil)) + ^((get () + (qref ,lb-form (get))) + (del* () + (qref ,lb-form (del*))) + (do-del () + (qref ,lb-form (del)))))) + +(defun sys:build-expander (forms return-get) + (with-gensyms (name) + ^(let ((,name (new list-builder))) + (flet ,(sys:list-builder-flets name) + (macrolet ((del (:form f : (expr nil expr-p)) + (if expr-p f '(do-del)))) + ,*forms + ,*(if return-get ^((qref ,name (get))))))))) + +(defmacro build (. forms) + (sys:build-expander forms t)) + +(defmacro buildn (. forms) + (sys:build-expander forms nil)) + +(defstruct list-builder () + head tail + + (:postinit (self) + (set self.head (cons nil self.head) + self.tail self.head)) + + (:method oust (self . lists) + (if lists + (let ((nl [apply append lists])) + (set self.tail (usr:rplacd self.head nl))) + (set self.tail (usr:rplacd self.head nil))) + self) + + (:method add (self . items) + (let ((st self.tail)) + (rplacd st (append (cdr st) nil)) + (let ((tl (last st))) + (usr:rplacd tl (append (cdr tl) items)) + (set self.tail tl))) + self) + + (:method add* (self . items) + (let ((h self.head)) + (usr:rplacd h (append items (cdr h)))) + self) + + (:method pend (self . lists) + (when lists + (let ((st self.tail)) + (rplacd st (append (cdr st) nil)) + (let* ((tl (last st)) + (cp (tailp tl (car (last lists)))) + (nl [apply append lists])) + (usr:rplacd tl (append (cdr tl) (if cp (copy-list nl) nl))) + (set self.tail tl))) + self)) + + (:method pend* (self . lists) + (let* ((h self.head) + (pf [apply append (append lists (list (cdr h)))])) + (usr:rplacd h pf) + (set self.tail h)) + self) + + (:method ncon (self . lists) + (when lists + (let* ((tl (last self.tail)) + (nl [apply nconc lists])) + (usr:rplacd tl (nconc (cdr tl) nl)) + (set self.tail tl)) + self)) + + (:method ncon* (self . lists) + (let* ((h self.head) + (pf [apply nconc (append lists (list (cdr h)))])) + (usr:rplacd h pf) + (if (eq self.tail h) + (set self.tail pf))) + self) + + (:method get (self) + (cdr self.head)) + + (:method del (self) + (whenlet ((hd self.head) + (chd (cdr self.head))) + (when (eq self.tail chd) + (set self.tail hd)) + (prog1 (car chd) (usr:rplacd hd (cdr chd))))) + + (:method del* (self) + (whenlet ((hd self.head) + (chd (cdr self.head))) + (if (cdr chd) + (let* ((tl self.tail) + (l2 (nthlast 2 tl))) + (if (cdr l2) + (prog1 + (cadr l2) + (usr:rplacd l2 nil)) + (let* ((l10 (nthlast 10 hd)) + (l2 (nthlast 2 l10))) + (prog1 + (cadr l2) + (usr:rplacd l2 nil) + (set self.tail l10))))) + (prog1 + (car chd) + (usr:rplacd hd nil) + (set self.tail hd)))))) + +(defun build-list (: init) + (new list-builder head init)) |