;; 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))