"Fossies" - the Fresh Open Source Software Archive

Member "txr-225/share/txr/stdlib/build.tl" (11 Sep 2019, 4444 Bytes) of package /linux/misc/txr-225.tar.bz2:


As a special service "Fossies" has tried to format the requested text file into HTML format (style: standard) with prefixed line numbers. Alternatively you can here view or download the uninterpreted source code file. See also the latest Fossies "Diffs" side-by-side code changes report for "build.tl": 224_vs_225.

    1 ;; Copyright 2016-2019
    2 ;; Kaz Kylheku <kaz@kylheku.com>
    3 ;; Vancouver, Canada
    4 ;; All rights reserved.
    5 ;;
    6 ;; Redistribution and use in source and binary forms, with or without
    7 ;; modification, are permitted provided that the following conditions are met:
    8 ;;
    9 ;; 1. Redistributions of source code must retain the above copyright notice, this
   10 ;;    list of conditions and the following disclaimer.
   11 ;;
   12 ;; 2. Redistributions in binary form must reproduce the above copyright notice,
   13 ;;    this list of conditions and the following disclaimer in the documentation
   14 ;;    and/or other materials provided with the distribution.
   15 ;;
   16 ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
   17 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
   18 ;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
   19 ;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
   20 ;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
   21 ;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
   22 ;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
   23 ;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
   24 ;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
   25 ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
   26 
   27 (defstruct list-builder ()
   28   head tail
   29 
   30   (:postinit (bc)
   31     (set bc.head (cons nil bc.head)
   32          bc.tail bc.head))
   33 
   34   (:method add (self . items)
   35     (let ((st self.tail))
   36       (rplacd st (append (cdr st) nil))
   37       (let ((tl (last st)))
   38         (usr:rplacd tl (append (cdr tl) items))
   39         (set self.tail tl)))
   40     nil)
   41 
   42   (:method add* (self . items)
   43     (let ((h self.head))
   44       (usr:rplacd h (append items (cdr h))))
   45     nil)
   46 
   47   (:method pend (self . lists)
   48     (when lists
   49       (let ((st self.tail))
   50         (rplacd st (append (cdr st) nil))
   51         (let* ((tl (last st))
   52                (cp (tailp tl (car (last lists))))
   53                (nl [apply append lists]))
   54           (usr:rplacd tl (append (cdr tl) (if cp (copy-list nl) nl)))
   55           (set self.tail tl)))
   56       nil))
   57 
   58   (:method pend* (self . lists)
   59     (let* ((h self.head)
   60            (pf [apply append (append lists (list (cdr h)))]))
   61       (usr:rplacd h pf)
   62       (set self.tail h))
   63     nil)
   64 
   65   (:method ncon (self . lists)
   66     (when lists
   67       (let* ((tl (last self.tail))
   68              (nl [apply nconc lists]))
   69         (usr:rplacd tl (nconc (cdr tl) nl))
   70         (set self.tail tl))
   71       nil))
   72 
   73   (:method ncon* (self . lists)
   74     (let* ((h self.head)
   75            (pf [apply nconc (append lists (list (cdr h)))]))
   76       (usr:rplacd h pf)
   77       (if (eq self.tail h)
   78         (set self.tail pf)))
   79     nil)
   80 
   81   (:method get (self)
   82     (cdr self.head))
   83 
   84   (:method del (self)
   85     (whenlet ((hd self.head)
   86               (chd (cdr self.head)))
   87       (when (eq self.tail chd)
   88         (set self.tail hd))
   89       (prog1 (car chd) (usr:rplacd hd (cdr chd)))))
   90 
   91   (:method del* (self)
   92     (whenlet ((hd self.head)
   93               (chd (cdr self.head)))
   94       (if (cdr chd)
   95         (let* ((tl self.tail)
   96                (l2 (nthlast 2 tl)))
   97           (if (cdr l2)
   98             (prog1
   99               (cadr l2)
  100               (usr:rplacd l2 nil))
  101             (let* ((l10 (nthlast 10 hd))
  102                    (l2 (nthlast 2 l10)))
  103               (prog1
  104                 (cadr l2)
  105                 (usr:rplacd l2 nil)
  106                 (set self.tail l10)))))
  107         (prog1
  108           (car chd)
  109           (usr:rplacd hd nil)
  110           (set self.tail hd))))))
  111 
  112 (defun sys:list-builder-flets (lb-form)
  113   (nconc
  114     (collect-each ((op '(add add* pend pend* ncon ncon*)))
  115       ^(,op (. args)
  116          (qref ,lb-form (,op . args))))
  117     ^((get ()
  118         (qref ,lb-form (get)))
  119       (del* ()
  120         (qref ,lb-form (del*)))
  121       (do-del ()
  122         (qref ,lb-form (del))))))
  123 
  124 (defun build-list (: init)
  125   (new list-builder head init))
  126 
  127 (defun sys:build-expander (forms return-get)
  128   (with-gensyms (name)
  129     ^(let ((,name (new list-builder)))
  130        (flet ,(sys:list-builder-flets name)
  131          (macrolet ((del (:form f : (expr nil expr-p))
  132                       (if expr-p f '(do-del))))
  133            ,*forms
  134            ,*(if return-get ^((qref ,name (get)))))))))
  135 
  136 (defmacro build (. forms)
  137   (sys:build-expander forms t))
  138 
  139 (defmacro buildn (. forms)
  140   (sys:build-expander forms nil))