;; -*- Mode: Lisp; -*-
;; ---------------------------------------------------------------------------
;;     Title: Augmenting Lexical Environments
;;   Created: 2023-02-10
;;    Author: Gilbert Baumann <gilbert@bauhh.de>
;;   License: MIT style (see below)
;; ---------------------------------------------------------------------------
;;  (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.

(in-package :cl-user)

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

(eval-when (:compile-toplevel :load-toplevel :execute)
  #+CCL  (defun process-in-env (form env)
           ;; There also is (CCL::COMPILE-NAMED-FUNCTION `(LAMBDA () ,form) :ENV env)
           (ccl::cheap-eval-in-environment `(lambda () ,form) env))

  #+SBCL (defun process-in-env (form env)
           ;; There also is SB-C:COMPILE-IN-LEXENV
           (sb-cltl2:macroexpand-all form env))

  #+ECL (defun process-in-env (form env)
          (si:eval-with-env `(lambda () ,form) env nil t :compile-toplevel))

  #+ABCL (defun process-in-env (form env)
           (precompiler:precompile-form form nil env))

  #+CLISP (defun process-in-env (form env)
            (if env
                (let ((sys::*venv* (aref env 0))
                      (sys::*fenv* (aref env 1)))
                  (sys::make-macro-expander `(,(gensym) () ,form) nil))
                (sys::make-macro-expander `(,(gensym) () ,form) nil)))

  #+EXCL (defun process-in-env (form env)
           (excl::%eval-compile-time form env))

  #-(OR CCL SBCL ECL ABCL CLISP EXCL)
  #.(error "Sorry") )

;;;

(defvar *cont*)

(defmacro --capture-- (&rest args &environment env)
  (apply *cont* env args))

(defmacro with-augmented-lexenv ((env-var template) &body body)
  (let ((b (gensym "B.")))
    `(block ,b
       (let ((*cont* (lambda (,env-var)
                       (declare (ignorable ,env-var))
                       (return-from ,b (locally ,@body)))))
         (process-in-env ,template ,env-var)
         (error "oops we caught nothing"))))) 

;;;

(defmacro with-lexenv-augmented-by-symbol-macro ((env-var sym def) &body body)
  `(with-augmented-lexenv (,env-var `(symbol-macrolet ((,,sym ,,def)) (--capture--)))
     ,@body))

(defmacro with-lexenv-augmented-by-macros ((env-var defs) &body body)
  `(with-augmented-lexenv (,env-var `(macrolet ,,defs (--capture--)))
     ,@body))


;;;; Test

(defmacro foo () :outer-foo)
(defmacro bar () :outer-bar)

(defmacro frob (&environment env)
  (with-lexenv-augmented-by-symbol-macro (env 'y 'the-y)
    (with-lexenv-augmented-by-macros (env '((foo () :inner-foo)))
      `'(,(macroexpand 'x env) ,(macroexpand 'y env)
         ,(macroexpand '(foo) env)
         ,(macroexpand '(bar) env)))))
  
(defun test ()
  (symbol-macrolet ((x the-x))
    (declare (type fixnum x))
    (macrolet ((bar () :inner-bar))
      (frob))))

(format t "~&~%;should be (X THE-Y :INNER-FOO :OUTER-BAR):")
(print (frob))  
(format t "~&;should be ((THE FIXNUM THE-X) THE-Y :INNER-FOO :INNER-BAR):")
(print (test))
(terpri)
(force-output)