;; -*- Mode: Lisp; -*-
;; ---------------------------------------------------------------------------
;;     Title: MACROEXPAND-ALL
;;   Created: 2023-02-10
;;    Author: Gilbert Baumann <gilbert@bauhh.de>
;;   License: MIT
;; ---------------------------------------------------------------------------
;;  (c) copyright 2023 by Gilbert Baumann

;;  Permission is hereby granted, free of charge, to any person obtaining
;;  a copy of this software and associated documentation files (the
;;  "Software"), to deal in the Software without restriction, including
;;  without limitation the rights to use, copy, modify, merge, publish,
;;  distribute, sublicense, and/or sell copies of the Software, and to
;;  permit persons to whom the Software is furnished to do so, subject to
;;  the following conditions:
;; 
;;  The above copyright notice and this permission notice shall be
;;  included in all copies or substantial portions of the Software.
;; 
;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 
;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

(defpackage :meall
  (:use :cl)
  (:export #:macroexpand-all))

(in-package :meall)


;;;; -- Overview -------------------------------------------------------------

;; This is an attempt of a proper implementation of MACROEXPAND-ALL for
;; Common Lisp. By proper we mean that a form could be fully expanded
;; with regard to a given lexical environment and thus would be of use
;; from inside some other macro.

;; However, there is no portable way to achieve that. Common Lisp just
;; lacks the necessary infracture. Actually, an &optional env argument
;; to EVAL and COMPILE would suffice and even be sane, when the same
;; restrictions as with MACROLET macro functions would apply.

;; The idea is to find some perhaps internal symbol with each CL
;; implementation to trigger minimal compilation with regard to a given
;; lexical environment. And there must be _some_ such function near the
;; implementation of MACROLET.

;; Suppose we had some EVAL-IN-ENV, we could augment a given environment
;; _env_ with e.g. a new lexical variable X by saying:

;;    (EVAL-IN-ENV `(LAMBDA () (LET (X) (FROB))) env)

;; EVAL-IN-ENV must use minimal compilation to craft the function to be
;; returned. We arrange for FROB being a macro of our own, like e.g.

;;    (DEFMACRO FROB (&ENVIRONMENT ENV)
;;      .. do something interesting with ENV ...)

;; This FROB macro is our spy deep inside whatever part of the Lisp
;; compiler and it can deal with the environment and beam itself out of
;; enemy territory by means of THROW or RETURN-FROM easily and will
;; never be caught. Don't take the environment with you, the compiler
;; will quickly noctice and trigger an alarm. Agents will come after
;; you, find your hiding place and put you to interrogation.

;; This way for each Lisp implementation the only thing we need to find,
;; is some EVAL, COMPILE, or macroprocessing routine taking a lexical
;; environment. The API to augment this environment by various
;; informations like lexical variables, declarations of all kinds,
;; lexical macros etc, is just the standard CL special forms to do so.
;; Porting this to another Lisp implementation thus is one extra line or
;; two.

;; As we don't care about the actual return value from our fictive
;; EVAL-IN-ENV, we rather call this PROCESS-IN-ENV.

;; I found actual EVAL-IN-ENV functions with CCL, ECL, and ACL. For SBCL
;; we use its SB-CLTL2:MACROEXPAND-ALL, for CLISP I found the very piece
;; that crafts lexical macro functions. I am not too happy with the
;; latter though.


;;;; -- Implementation -------------------------------------------------------


;;;; First of all our hack.

#+SBCL (eval-when (:compile-toplevel :load-toplevel :execute)
         (require :sb-cltl2))

(defun process-in-env (form env)
  "Processes the form _form_ in the lexical environment _env_ for
   macros. The only promise is that eventually all macros are
   processed, and nothing is said about the return value. This is our
   secret backdoor into the compiler. Don't steal. Remember: This is
   covert operation. Get get out quick, if you can by means of
   teleportation, which for reasons is called RETURN-FROM."
  '(pprint `(cheap-eval ,form))
  #.#.(OR'

     #+CCL'       (ccl::cheap-eval-in-environment `(lambda () ,form) env)
     #+SBCL'      (sb-cltl2:macroexpand-all form env)
     #+ECL'       (si:eval-with-env `(lambda () ,form) env nil t :compile-toplevel)
     #+ABCL'      (precompiler:precompile-form form nil env)
     #+CLISP'     (progv (and env '(sys::*venv* sys::*fenv*))
                         (and env (list (aref env 0) (aref env 1)))
                    (sys::make-macro-expander `(,(gensym) () ,form) nil))
     #+EXCL'      (excl::%eval-compile-time form env)

     (error "Sorry"))
  nil)

;;; Next, for symbol macros we demand that (THE ...) is wrapped when the
;;; thingy has declared types. For that we need a bare minimum
;;; VARIABLE-INFORMATION.

#+(or)
(defun variable-information (var &optional env)
  #+CCL         (ccl:variable-information var env) ;fine
  ;; No luck with SBCL. It hides type information both with
  ;; SB-CLTL2:VARIABLE-INFORMATION and SB-WALKER::ENV-VAR-TYPE
  #+SBCL        nil                                
  #-(OR CCL SBCL)
  nil)

(defmacro --spy-- (cont &rest args &environment env)
  "This is our little spy, it has all it could ever wish for: A
continuation, some arguments and the holy lexical environment."
  (apply cont env args))

(defvar *form-fun*)
(defun form (&rest args)
  "Dynamically bound function to be called by templates for forms that
   seek expansion."
  (apply *form-fun* args))

(defmacro macroexpand-template (template env)
  ;;
  ;; This works in three passes. First we name each form passed via #'FORM
  ;; aka *FORM-FUN* and remember them in `in-alist'. We do this naming
  ;; because we don't want to make any bets on the order the Lisp at hand
  ;; may expand macros. Further we don't trust the compiler to not touch
  ;; our s-expressions. There is only so much harm that could be done to
  ;; small integers.
  ;;
  `(let ((in-alist nil) (out-alist nil))
     ;; First pass, gathering; no ME yet
     (let ((*form-fun*
            (let ((serial 0))
              (lambda (form)
                (push (cons (incf serial) form) in-alist)
                nil))))
       ,template)
     ;; Second pass
     ;;
     ;; We contruct the template again putting (--SPY-- <cont> <id>) forms
     ;; there. The IDs match those we came up with above. This --SPY-- macro
     ;; would the invoke the contintuation with the given ID and the current
     ;; lexenv.
     ;;
     ;; The spy then looks up the ID up in `in-alist', macroexpand the form
     ;; found there using the very lexical environment it is at put the
     ;; result onto `out-alist'. And we remove it from `in-alist' as well to
     ;; be able to tell when we're done. If we're done, we take a non-local
     ;; exit to give the Lisp no time to complain about unused variables or
     ;; such.
     ;;
     (when in-alist
       (block mission
         (let ((*form-fun*
                (let ((serial 0))
                  (lambda (x)
                    `(--spy--,
                      (lambda (env id &aux it)
                        (setq in-alist (remove-if (lambda (q)
                                                    (when (eql (car q) id)
                                                      (setq it q)))
                                                  in-alist))
                        (when it
                          (setf (cdr it) (macroexpand-all x env))
                          (push it out-alist)
                          (unless in-alist (return-from mission t)))
                        nil)
                      ,(incf serial))))))
           (process-in-env ,template ,env))
         (error "We weren't caught?")))
     ;;
     ;; Third pass, construction
     ;;
     ;; This time we arrange for #'FORM to yield the macroexpansions we
     ;; gathered in the second pass and are done.
     ;;
     (let ((*form-fun*
            (let ((serial 0))
              (lambda (x)
                (declare (ignore x))
                (cdr (or (assoc (incf serial) out-alist)
                         (error "Very funny, ~A." (lisp-implementation-type))))))))
       ,template)) )


;;;; Macro Expander

(defun macroexpand-all (form &optional env)
  (let ((new (macroexpand-all-1 form env)))
    #+CCL (ccl::note-source-transformation form new)
    new))

(defvar *yet* nil)

(defun macroexpand-all-1 (form &optional env)
  (typecase form
    (symbol     (let ((new (macroexpand-1 form env)))
                  (if (eq new form)
                      form
                      (macroexpand-all-1 new env))))
    (atom form)

    ;; all forms
    ((cons (member #+CCL AND
                   #+CCL OR
                   #+CCL MULTIPLE-VALUE-LIST

                   CATCH
                   IF
                   LOAD-TIME-VALUE
                   MULTIPLE-VALUE-CALL
                   MULTIPLE-VALUE-PROG1
                   PROGN
                   #+CCL PROG1
                   #+CCL PROG2
                   PROGV
                   THROW
                   UNWIND-PROTECT))
     (cons (car form) (macroexpand-list-all (cdr form) env)))
    ;; First untouched
    ((cons (member BLOCK
                   GO
                   EVAL-WHEN
                   QUOTE
                   THE
                   RETURN-FROM))
     (list* (car form) (cadr form) (macroexpand-list-all (cddr form) env)))
    ;; All untouched
    #+CCL
    ((cons (member DECLAIM))
     form)
    ;; Special care
    ((cons (member FLET LABELS))
     (macroexpand-template
      `(,(car form)
         ,(mapcar #'lambda-like-template (cadr form))
         ,@(body-template (cddr form)))
      env))
    ;;
    ((cons (member FUNCTION) t)
     (destructuring-bind (name) (cdr form)
       `(,(car form) ,(macroexpand-fun name env))))
    ;;
    ((cons (member LET LET*) t)
     (macroexpand-template
      `(,(car form) ,(mapcar (lambda (b)
                               (cond ((atom b) b)
                                     (t `(,(car b) ,@(mapcar #'form (cdr b))))))
                             (cadr form))
         ,@(body-template (cddr form)))
      env))
    ;;
    ((cons (member LOCALLY) t)
     (macroexpand-template `(,(car form) ,@(body-template (cdr form))) env))
    ;;    
    ((cons (member MACROLET) t)
     ;; ### What happens to declarations which would apply to this macro?!
     ;; ### Do we want to expand macro-definitions as well?
     (macroexpand-template `(,(car form) ,(cadr form) ,@(body-template (cddr form))) env))
    ;;
    ((cons (member SETQ) t)
     ;; Some Lisp expand (SETF <symbol-macro> ..) back to
     ;; (SETQ <symbol-macro> ...), so expand on our own.
     (let ((lostp nil))
       (labels ((aux (var-vals)
                  (cond ((or (atom var-vals)
                             (atom (cdr var-vals))
                             (not (symbolp (car var-vals))))
                         ;; We're lazy. Let someone else deal with possible lossage!
                         var-vals)
                        (t
                         (setq lostp (or lostp (nth-value 1 (macroexpand-1 (car var-vals) env))))
                         (list* (macroexpand-all (car var-vals) env)
                                (macroexpand-all (cadr var-vals) env)
                                (aux (cddr var-vals)))))))
         (let ((var-vals (aux (cdr form))))
           (if lostp
               (macroexpand-all `(setf ,@var-vals) env)
               `(,(car form) ,@var-vals))))))
    ;;
    ((cons (member SYMBOL-MACROLET) t)
     (macroexpand-template `(,(car form) ,(cadr form) ,@(body-template (cddr form))) env))
    ;;
    ((cons (member TAGBODY) t)
     (macroexpand-template
      `(TAGBODY
          ,@(mapcar (lambda (x)
                      (cond ((atom x) x)
                            ((atom (setq x (form x))) `(progn ,x))
                            (t x)))
                    (cdr form)))
      env))
    ;;
    ;; --- Implementation Specific Special Forms
    ;;
    ((cons (member #+CCL   CCL:COMPILER-LET
                   #+CMUCL EXT:COMPILER-LET
                   #+CLISP EXT:COMPILER-LET
                   #+ECL   EXT:COMPILER-LET
                   #+EXCL  EXCL:COMPILER-LET) t)
     `(progn ,@(cddr (macroexpand-template `(,(car form) ,(cadr form) ,@(body-template (cddr form))) env))))
    ;;
    ;; CCL
    ;;
    #+CCL       ((cons (member CCL:NFUNCTION) t)
                 (destructuring-bind (name lambda) (cdr form)
                   `(,(car form) ,name ,(macroexpand-fun lambda env))))
    #+CCL       ((cons (member CCL::WITH-C-FRAME) t)
                 (destructuring-bind (var &body body) (cdr form)
                   (macroexpand-template `(,(car form) ,var ,@(body-template body)) env)))
    #+CCL       ((cons (member CCL::WITH-VARIABLE-C-FRAME) t)
                 (destructuring-bind (size var &body body) (cdr form)
                   (macroexpand-template `(,(car form) ,(form size) ,var ,@(body-template body)) env)))
    #||
    #+CCL       ((cons (member CCL::PPC-LAP-FUNCTION CCL::X86-LAP-FUNCTION CCL::ARM-LAP-FUNCTION) t)
                 (destructuring-bind (name bindings &body body) (cdr form)
                   (nyi)))
    #+CCL       ((cons (member CCL::FBIND) t) ;No idea
                 (nyi))
    ||#                


    #+CCL
    ((cons (member MULTIPLE-VALUE-BIND DESTRUCTURING-BIND) t)
     (macroexpand-template `(,(car form) ,(cadr form) ,(form (caddr form))
                              ,@(body-template (cdddr form)))
                           env))


    ((cons symbol t)
     (let (it)
       (assert (not (special-operator-p (car form))) ()
               "Oops, where did ~S come from which is a special operator.~%~S" (car form) form)
       ;;
       (when (setq it (macro-function (car form) env))
         (let ((new (funcall it form env)))
           (unless (eq new form)
             (return-from macroexpand-all-1 (macroexpand-all-1 new env)))))
       ;;
       (cond ((and (setq it (compiler-macro-function (car form) env))
                   (not (member form *yet*)))
              (format t "~%====== Compiler macro found: ~S~%" (car form))
              (force-output)
              (let ((new (funcall it form env)))
                (if (eq new form)
                    (cons (macroexpand-fun (car form) env)
                          (macroexpand-list-all (cdr form) env))
                    (progn
                      (let ((*print-level* 4))
                        (format t "~&  old = ~S~%" form)
                        (format t "~&  new = ~S~%" new)
                        (force-output)
                        '(sleep 1/2))
                      (let ((*yet* (list* form new *yet*)))
                        (macroexpand-all-1 new env))))))
             (t
              (cons (macroexpand-fun (car form) env)
                    (macroexpand-list-all (cdr form) env))))))
    ;;
    ((cons (cons (member LAMBDA) t) t)
     (cons (macroexpand-fun (car form) env)
           (macroexpand-list-all (cdr form) env)))

    (t
     (error "Bad form: ~S" form))))

(defun macroexpand-list-all (forms env)
  (mapcar #'(lambda (x) (macroexpand-all x env)) forms))

(defun macroexpand-fun (fun env)
  (etypecase fun
    ((or symbol (cons (member SETF) (cons symbol null)))
     fun)
    ((cons (member LAMBDA) t)
     (macroexpand-template (lambda-like-template fun) env))
    #+SBCL
    ((cons (member SB-INT:NAMED-LAMBDA) t)
     (macroexpand-template
     `(,(car fun)
        ,(cadr fun)
        ,(lambda-list-template (caddr fun))
        ,@(body-template (cdddr fun)))
     env))
    ))

(defun body-template (forms)
  (let ((p (member-if-not (lambda (x) (typep x '(cons (member DECLARE)))) forms)))
    (append (ldiff forms p)
            (mapcar #'(lambda (x)
                        (if (typep (setq x (form x)) '(cons (member DECLARE)))
                            `(progn ,x)
                            x))
                    p))))

(defun lambda-like-template (form)
  `(,(car form)
     ,(lambda-list-template (cadr form))
     ,@(body-template (cddr form))))

(defun lambda-list-template (lambda-list)
  (mapcar (lambda (p)
            (if (atom p)
                p
                (cons (car p)  ; <var> or (<key> <var>), we don't care
                      (and (cdr p) (cons (form (cadr p)) ;<init>
                                         (cddr p)))))) ;tail for <svar> or garbage, we don't care
          lambda-list))

;;; Still to support:

;; CCL 1.11-r16635        => (CCL::FBIND
;;                             CCL::X86-LAP-FUNCTION)
;; SBCL 2.0.2             => (SB-C::%%ALLOCATE-CLOSURES SB-C::%CLEANUP-FUN
;;                                                      SB-C::%ESCAPE-FUN
;;                                                      SB-C::%FUNCALL
;;                                                      SB-C::%FUNCALL-LVAR
;;                                                      SB-SYS:%PRIMITIVE
;;                                                      SB-C::%WITHIN-CLEANUP
;;                                                      SB-C::BOUND-CAST
;;                                                      SB-C::GLOBAL-FUNCTION
;;                                                      SB-SYS:NLX-PROTECT
;;                                                      SB-C::WITH-ANNOTATIONS)
;; CMUCL 19c              => (C::%CLEANUP-FUNCTION C::%ESCAPE-FUNCTION
;;                                                 C::%FUNCALL
;;                                                 SYSTEM:%PRIMITIVE
;;                                                 C::%WITHIN-CLEANUP
;;                                                 C::COMPILER-OPTION-BIND
;;                                                 EXTENSIONS:TRULY-THE)
;; CLISP 2.48             => (SYSTEM::FUNCTION-MACRO-LET)
;; ECL 13.5.1             => ()
;; ACL 10.1               => (EXCL:ATOMIC-CONDITIONAL-SETQ)
;; ABCL 1.8.0             => (THREADS:SYNCHRONIZED-ON JVM:WITH-INLINE-CODE)