;; Copyright 2017-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.
(defvar sys:*op-ctx*)
(sys:make-struct-type
'sys:op-ctx nil nil '(form gens up meta rec recvar) nil
(lambda (me)
(slotset me 'up sys:*op-ctx*)
(slotset me 'meta (gensym "meta-")))
nil nil)
(defun sys:ensure-op-arg (ctx n)
(let ((ag (slot ctx 'gens)))
(when (> n 1024)
['compile-error (slot ctx 'form)
"@~a calls for function with too many arguments" n])
(for ((i (len ag)) (l))
((<= i n)
(sys:setq ag (append ag (nreverse l)))
(slotset ctx 'gens ag)
[ag n])
((sys:setq i (succ i)))
(sys:setq l (cons (gensym `arg-@(if (plusp i) i "rest")-`) l)))))
(defun sys:op-meta-p (expr)
(tree-case expr
((x y . r) (and (null r)
(cond
((eq x 'sys:expr) (sys:op-meta-p y))
((eq x 'sys:var) (or (integerp y)
(eq y 'rest))))))))
(defun sys:op-rec-p (expr)
(tree-case expr
((x (y . r)) (and (eq x 'sys:expr) (eq y 'usr:rec)))))
(defun sys:op-ensure-rec (ctx : recvar)
(when recvar
(slotset ctx 'recvar t))
(or (slot ctx 'rec) (slotset ctx 'rec (gensym "rec-"))))
(defun sys:op-alpha-rename (f e op-args do-nested-metas)
(let* ((ctx sys:*op-ctx*)
(code ^(macrolet ((sys:expr (:form f arg)
(let ((ctx ,ctx))
(cond
((and (slot ctx 'up)
(or (sys:op-meta-p arg)
(sys:op-rec-p arg)
(equal arg '(sys:var usr:rec))))
^(,(slot (slot ctx 'up) 'meta) (quote ,arg)))
((sys:op-rec-p f)
^(,(sys:op-ensure-rec ctx) ,*(rest arg)))
(t f))))
(sys:var (:form f arg . mods)
(cond
((sys:op-meta-p f)
(unless (integerp arg)
(sys:setq arg 0))
(sys:ensure-op-arg ,ctx arg))
((equal f '(sys:var usr:rec))
(sys:op-ensure-rec ,ctx t))
(t f)))
,*(if do-nested-metas
^((,(slot ctx 'meta) ((quote arg)) arg))))
,op-args)))
(expand code e)))
(eval-only
(defmacro op-ignerr (x)
^(sys:catch (error) ,x () (error (. args)))))
(defun sys:op-expand (f e args)
(unless args
['compile-error f "arguments required"])
(let* ((compat (and (plusp sys:compat) (<= sys:compat 225)))
(ctx (make-struct 'sys:op-ctx ^(form ,f)))
(sys:*op-ctx* ctx)
(sym (car f))
(syntax-0 (if (eq sym 'do) args ^[,*args]))
(syntax-1 (if (or (null syntax-0) (neq sym 'do) compat)
;; not do, or empty do syntax, or compat mode.
(sys:op-alpha-rename f e syntax-0 nil)
;; try to expand args as-is, catching errors
(let ((syn (op-ignerr (sys:op-alpha-rename f e
syntax-0
nil))))
(if syn
;; args expanded
(if (slot ctx 'gens)
;; there are metas: okay, use expansion as-is.
syn
;; no metas: add @1 at the end and expand
;; again, without catching errors.
(sys:op-alpha-rename f e
(append syntax-0
'(@1))
nil))
;; args didn't expand, thus need the extra
;; element. But we can't add a @1 because by
;; doing so we could be introducing metas.
;; We add a gensym instead to try to satisfy
;; the syntax without adding metas. If all works,
;; we can use a symacrolet pass to replace
;; that gensym with @1.
(let ((syn (sys:op-alpha-rename
f e (append syntax-0
(list (gensym)))
nil)))
;; It didn't blow up with the gensym. But
;; if there are metas, we don't want to be
;; be adding this gensym. We know that the
;; form does not expand without the gensym.
;; So we repeat that expansion, but this time
;; without op-ignerr. This will flush out
;; the error.
(when (slot ctx 'gens)
(sys:op-alpha-rename f e syntax-0 nil))
;; There were no metas. OK, let's augment
;; syntax-0 with @1 instead of the gensym.
(sys:op-alpha-rename f e
(append syntax-0 '(@1))
nil))))))
(syntax-2 (sys:op-alpha-rename f e syntax-1 t))
(metas (slot ctx 'gens))
(rec (slot ctx 'rec))
(recvar (slot ctx 'recvar))
(rest-sym (sys:ensure-op-arg ctx 0))
(lambda-interior (let ((fargs (tree-case syntax-2
((a b . fa) fa))))
(cond
((and (eq sym 'lop) fargs)
(let ((fargs-l1 (mapcar (lambda (farg)
^(sys:l1-val ,farg))
fargs)))
;; no cadr here to avoid circular autoload
^[sys:apply ,(car (cdr syntax-2))
(append ,rest-sym (list ,*fargs-l1))]))
((or metas (eq sym 'do)) syntax-2)
(t (append syntax-2 rest-sym))))))
(let ((metas (slot ctx 'gens)))
(cond
(recvar ^(sys:lbind ((,rec (lambda (,*(cdr metas) . ,rest-sym)
(let ((,rec (fun ,rec)))
,lambda-interior))))
(fun ,rec)))
(rec ^(sys:lbind ((,rec (lambda (,*(cdr metas) . ,rest-sym)
,lambda-interior)))
(fun ,rec)))
(t ^(lambda (,*(cdr metas) . ,rest-sym)
,lambda-interior))))))
(defmacro op (:form f :env e . args)
(sys:op-expand f e args))
(defmacro do (:form f :env e . args)
(sys:op-expand f e args))
(defmacro lop (:form f :env e . args)
(sys:op-expand f e args))
(defmacro ldo (op . args)
^(do ,op @1 ,*args))
(defmacro ap (. args)
^(apf (op ,*args)))
(defmacro ip (. args)
^(ipf (op ,*args)))
(defmacro ado (. args)
^(apf (do ,*args)))
(defmacro ido (. args)
^(ipf (do ,*args)))
(defmacro ret (. args)
^(op identity (progn @rest ,*args)))
(defmacro aret (. args)
^(ap identity (progn @rest ,*args)))
(defun sys:opip-expand (e clauses)
(collect-each ((c clauses))
(if (atom c)
c
(let ((sym (car c)))
(if (member sym '(dwim uref qref))
c
(let ((opdo (if (or (special-operator-p (car c))
(macro-form-p c e)) 'do 'op)))
^(,opdo ,*c)))))))
(defmacro opip (:env e . clauses)
^[chain ,*(sys:opip-expand e clauses)])
(defmacro oand (:env e . clauses)
^[chand ,*(sys:opip-expand e clauses)])
(defmacro flow (val . opip-args)
^(call (opip ,*opip-args) ,val))