"Fossies" - the Fresh Open Source Software Archive

Member "txr-217/share/txr/stdlib/op.tl" (10 Jun 2019, 5213 Bytes) of package /linux/misc/txr-217.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.

    1 ;; Copyright 2017-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 (defvar sys:*op-ctx*)
   28 
   29 (sys:make-struct-type
   30   'sys:op-ctx nil nil '(form gens up meta) nil
   31   (lambda (me)
   32     (slotset me 'up sys:*op-ctx*)
   33     (slotset me 'meta (gensym "meta-")))
   34   nil nil)
   35 
   36 (defun sys:ensure-op-arg (ctx n)
   37   (let ((ag (slot ctx 'gens)))
   38     (when (> n 1024)
   39       ['compile-error (slot ctx 'form)
   40                       "@~a calls for function with too many arguments" n])
   41     (for ((i (len ag)) (l))
   42          ((<= i n)
   43           (sys:setq ag (append ag (nreverse l)))
   44           (slotset ctx 'gens ag)
   45           [ag n])
   46          ((sys:setq i (succ i)))
   47       (sys:setq l (cons (gensym `arg-@(if (plusp i) i "rest")-`) l)))))
   48 
   49 (defun sys:op-meta-p (expr)
   50   (tree-case expr
   51     ((x y . r) (and (null r)
   52                     (cond
   53                       ((eq x 'sys:expr) (sys:op-meta-p y))
   54                       ((eq x 'sys:var) (or (integerp y)
   55                                            (eq y 'rest))))))))
   56 
   57 (defun sys:op-alpha-rename (f e op-args do-nested-metas)
   58   (let* ((ctx sys:*op-ctx*)
   59          (code ^(macrolet ((sys:expr (:form f arg)
   60                              (let ((ctx ,ctx))
   61                                (if (and (slot ctx 'up) (sys:op-meta-p arg))
   62                                  ^(,(slot (slot ctx 'up) 'meta) (quote ,arg))
   63                                f)))
   64                            (sys:var (:form f arg . mods)
   65                              (cond
   66                                ((and (not mods) (sys:op-meta-p f))
   67                                 (unless (integerp arg)
   68                                   (sys:setq arg 0))
   69                                 (sys:ensure-op-arg ,ctx arg))
   70                                (t f)))
   71                            ,*(if do-nested-metas
   72                                ^((,(slot ctx 'meta) ((quote arg)) arg))))
   73                   ,op-args)))
   74     (expand code e)))
   75 
   76 (defun sys:op-expand (f e args)
   77   (let* ((ctx (make-struct 'sys:op-ctx ^(form ,f)))
   78          (sys:*op-ctx* ctx)
   79          (sym (car f))
   80          (syntax-0 (if (eq sym 'do) ^(,*args) ^[,*args]))
   81          (syntax-1 (sys:op-alpha-rename f e syntax-0 nil))
   82          (syntax-2 (sys:op-alpha-rename f e syntax-1 t))
   83          (metas (slot ctx 'gens))
   84          (rest-sym (sys:ensure-op-arg ctx 0)))
   85      (unless args
   86        ['compile-error f "arguments required"])
   87     ^(lambda (,*(cdr metas) . ,rest-sym)
   88        ,(let ((fargs (cdr (cdr syntax-2))))
   89           (cond
   90             ((and (eq sym 'lop) fargs)
   91              (let ((fargs-l1 (mapcar (lambda (farg)
   92                                        ^(sys:l1-val ,farg))
   93                                      fargs)))
   94                ^[sys:apply ,(car (cdr syntax-2))
   95                            (append ,rest-sym (list ,*fargs-l1))]))
   96             ((or metas (eq sym 'do))
   97              syntax-2)
   98             (t (append syntax-2 rest-sym)))))))
   99 
  100 (defmacro op (:form f :env e . args)
  101   (sys:op-expand f e args))
  102 
  103 (defmacro do (:form f :env e . args)
  104   (sys:op-expand f e args))
  105 
  106 (defmacro lop (:form f :env e . args)
  107   (sys:op-expand f e args))
  108 
  109 (defmacro ap (. args)
  110   ^(apf (op ,*args)))
  111 
  112 (defmacro ip (. args)
  113   ^(ipf (op ,*args)))
  114 
  115 (defmacro ado (. args)
  116   ^(apf (do ,*args)))
  117 
  118 (defmacro ido (. args)
  119   ^(ipf (do ,*args)))
  120 
  121 (defmacro ret (. args)
  122   ^(op identity (progn @rest ,*args)))
  123 
  124 (defmacro aret (. args)
  125   ^(ap identity (progn @rest ,*args)))
  126 
  127 (defun sys:opip-expand (e clauses)
  128   (collect-each ((c clauses))
  129     (if (atom c)
  130       c
  131       (let ((sym (car c)))
  132         (if (member sym '(dwim uref qref))
  133           c
  134           (let ((opdo (if (or (special-operator-p (car c))
  135                               (macro-form-p c e)) 'do 'op)))
  136             ^(,opdo ,*c)))))))
  137 
  138 (defmacro opip (:env e . clauses)
  139   ^[chain ,*(sys:opip-expand e clauses)])
  140 
  141 (defmacro oand (:env e . clauses)
  142   ^[chand ,*(sys:opip-expand e clauses)])