;;; -*- Mode:LISP; Package:LISP-INTERNALS; Base:10; Readtable:CL -*-
;;;
;;; DEFMACRO.LISP


; (shadowing-import '(k-lisp:defmacro))

(lisp:defmacro new-defmacro (&body macro-definition)
  (let ((macro-name (first macro-definition)))
    `(PROGN
       (SETF (MACRO-FUNCTION ',macro-name)
	     ',(new-expand-defmacro macro-definition NIL))
       ',macro-name)))

(defun macro-function (symbol)
  "If SYMBOL has a macro definition, return its expander function.  Otherwise
return NIL."
  (if (fboundp symbol)
      (let ((symbol-function (symbol-function symbol)))
	(and (consp symbol-function)
	     (eq (car symbol-function) 'MACRO)
	     (cdr symbol-function)))
      NIL))

;;; EXPAND-DEFMACRO
;;;
;;; This constructs and returns a macro expansion function.  The expansion function takes
;;; two arguments, a macro-call form and an environment, and returns the expanded call
;;; form.
;;;
;;; X is a macro definition of the form (NAME LAMBDA-LIST . BODY); the CDR of a DEFMACRO
;;;    form and a MACROLET binding both fit into this pattern.
;;;
;;; ENV is the environment that the expansion function is being defined in.  (Note that
;;;    it is different from the expansion function's environment argument!)  It is used
;;;    to expand any macros that occur in the BODY.  Actually, it is only needed here to
;;;    look for macros in the BODY that expand into declarations.
;;;
;;; EXTRA-DECLARATIONS is a list of additional DECLARE forms to include in the expansion
;;;    function.
;;;
;;; The LAMBDA-LIST may contain any lambda-list keyword.  It may also be a dotted list, in
;;;    which case the last element of the list is considered a &REST argument.  The keywords
;;;    behave as follows:
;;;
;;;    &ENVIRONMENT argument is bound to the environment in which the macro is being expanded
;;;    &WHOLE argument is bound to the entire macro call form
;;;    &BODY argument is just like &REST; only one of these may occur
;;;    &OPTIONAL arguments act like you'd expect them to
;;;    &KEY arguments do not evaluate their keywords.  In other words, if you make a macro
;;;       call that contains a function evaluating into a keyword for &KEY, you will lose.
;;;    &ALLOW-OTHER-KEYS and :ALLOW-OTHER-KEYS are ignored.  Extraneous keywords are ignored.
;;;    &AUX arguments act like you'd expect them to
;;;    required arguments, if they are symbols, behave normally.  If a required parameter is
;;;       not a symbol, it is treated like a nested lambda-list which may contain any of the
;;;       above keywords.  This is the infamous, obnoxious power of lambda-list destructuring.


(defun expand-defmacro (x env &optional extra-declarations)
  (declare (ignore env)) ;Until macroexpand works
  (let ((name        (first x))
	(lambda-list (second x))
	(body        (cddr x))
	(macro-form  (gentemp 'MACROFORM))
	(macro-env   (gentemp 'MACROENV)))
    (multiple-value-bind (body decls doc-string)
	(GOBBLE-DECLARATIONS body T NIL)  ;make this last argument env when macroexpand works.
      (when doc-string (push `(DOCUMENTATION ,doc-string) decls))
      `(nc:NAMED-LAMBDA ,name (,macro-form &OPTIONAL ,macro-env)
	 (DECLARE ,@decls)
	 ,macro-env
	 (,(if (symbolp name) 'BLOCK 'PROGN) ,(if (symbolp name) name NIL)
	  (LET* ,(make-defmacro-let-bindings lambda-list macro-form macro-env)
	    (DECLARE ,@decls)
	    ,@extra-declarations
	    ,@body))))))

(defun make-defmacro-let-bindings (lambda-list macro-form macro-env)
  (let ((bindings NIL))
    (flet ((add-binding (binding)
	     (push binding bindings)))
      (make-let-bindings-for-nested-lambda-list lambda-list
						`(CDR ,macro-form)
						#'add-binding
						macro-form
						macro-env))
    (reverse bindings)))

(defun make-let-bindings-parse (lambda-list)
  (declare (global:special *moby-parse-required* *moby-parse-optional* *moby-parse-rest*
			   *moby-parse-key* *moby-parse-allow-other-keys* *moby-parse-aux*
			   *moby-parse-body* *moby-parse-whole* *moby-parse-environment*))
  (multiple-value-bind (required optional rest key allow aux body whole environment)
      (user::moby-parse-lambda-list lambda-list)
    (setq *moby-parse-required* required
	  *moby-parse-optional* optional
	  *moby-parse-rest* rest
	  *moby-parse-key* key
	  *moby-parse-allow-other-keys* allow
	  *moby-parse-aux* aux
	  *moby-parse-body* body
	  *moby-parse-whole* whole
	  *moby-parse-environment* environment)))

(defun make-let-bindings-for-nested-lambda-list (lambda-list path push-proc macro-form macro-env)
  (let ((index 0)
	;; These specials are used to avoid bumping into the 15-var stack frame limit.  Ugly.
	*moby-parse-required* *moby-parse-optional* *moby-parse-rest*
	*moby-parse-key* *moby-parse-allow-other-keys* *moby-parse-aux*
	*moby-parse-body* *moby-parse-whole* *moby-parse-environment*)
    (declare (global:special *moby-parse-required* *moby-parse-optional* *moby-parse-rest*
			     *moby-parse-key* *moby-parse-allow-other-keys* *moby-parse-aux*
			     *moby-parse-body* *moby-parse-whole* *moby-parse-environment*))
    ;; Undot the lambda list if it's dotted
    (when (not (null (cdr (last lambda-list))))
      (setq lambda-list (rplacd (last (copy-list lambda-list))
				`(&REST ,(cdr (last lambda-list))))))
    (make-let-bindings-parse lambda-list)
    ;; Make a dummy binding that checks for ample arguments
    (make-let-bindings-dummy-bind push-proc path lambda-list macro-form)
    (setq index
	  (make-let-bindings-do-whole-env-bindings-optionals index path push-proc macro-form macro-env))
    (make-let-bindings-do-key-parameter *moby-parse-key* index path push-proc)
    ;; Ignore the &ALLOW-OTHER-KEYS business entirely
    (make-let-bindings-do-aux-parameter *moby-parse-aux* push-proc)))

(defun make-let-bindings-dummy-bind (push-proc path lambda-list macro-form)
  (declare (global:special *moby-parse-optional* *moby-parse-required* *moby-parse-rest* *moby-parse-key* *moby-parse-aux* *moby-parse-whole*))
  (funcall push-proc `(IGNORE (REQUIRE-AMPLE-MACRO-ARGUMENTS 
				,(length *moby-parse-required*)
				,(if (or *moby-parse-rest* *moby-parse-key* *moby-parse-aux* *moby-parse-whole*)
				     NIL
				   (+ (length *moby-parse-required*) (length *moby-parse-optional*)))
				,path ',lambda-list (CAR ,macro-form)))))

(defun make-let-bindings-do-whole-env-bindings-optionals (index path push-proc macro-form macro-env)
  (declare (global:special *moby-parse-whole* *moby-parse-environment* 
			   *moby-parse-body* *moby-parse-rest* 
			   *moby-parse-required* *moby-parse-optional*))
  ;; Make a binding for the &WHOLE variable, if present
  (when *moby-parse-whole*
    (funcall push-proc `(,*moby-parse-whole* ,macro-form)))
  ;; Make a binding for the &ENVIRONMENT variable, if present
  (when *moby-parse-environment*
    (funcall push-proc `(,*moby-parse-environment* ,macro-env)))
  ;; Make bindings for the required parameters
  (setq index
	(make-let-bindings-make-binding-or-recurse *moby-parse-required* index path push-proc macro-form macro-env))
  ;; Make bindings for the &OPTIONAL parameters
  (setq index
	(make-let-bindings-do-optional-variable *moby-parse-optional* index path push-proc macro-form macro-env))
  ;; Make a binding for the &REST or &BODY parameter, if present
  (when (or *moby-parse-rest* *moby-parse-body*)
    (funcall push-proc `(,(if *moby-parse-rest* *moby-parse-rest* *moby-parse-body*)
			 (NTHCDR ,index ,path))))
  index)

(defun make-let-bindings-make-binding-or-recurse (vars index path push-proc macro-form macro-env)
  ;; This is mapped onto required parameters.
  (dolist (var vars index)
    (cond
      ((symbolp var)
       (funcall push-proc `(,var (NTH ,index ,path)))
       (incf index))
      ((listp var)
       (make-let-bindings-for-nested-lambda-list var `(NTH ,index ,path) push-proc macro-form macro-env)
       (incf index))
      (t
       (ferror "~S not a variable or a list" var)))))

(defun make-let-bindings-do-optional-variable (parameters index path push-proc macro-form macro-env)
  ;; This is mapped onto &OPTIONAL parameters.
  (dolist (parameter parameters index)
    (multiple-value-bind (var initform svar)
	(USER::PARSE-OPTIONAL-PARAMETER parameter)
      (funcall push-proc `(,var  (IF (<= (LENGTH ,path) ,index)
				     ,initform
				   (NTH ,index ,path))))
      (when svar
	(funcall push-proc `(,svar (IF (<= (LENGTH ,path) ,index)
				       NIL
				     T))))
      (incf index))))

(defun make-let-bindings-do-key-parameter (parameters index path push-proc)
  ;; This is mapped onto &KEY parameters.
  (dolist (parameter parameters)
    (multiple-value-bind (var initform svar keyword)
	(USER::PARSE-KEY-PARAMETER parameter)
      (funcall push-proc `(,var (GETF (NTHCDR ,index ,path) ,keyword ,initform)))
      (when svar
	(funcall push-proc 
		 `(,svar (LABELS ((FOO (LIST)
				       (COND ((NULL LIST) NIL)
					     ((EQ (CAR LIST) ,keyword) T)
					     (T (FOO (CDDR LIST))))))
			   (FOO (NTHCDR ,index ,path)))))))))

(defun make-let-bindings-do-aux-parameter (parameters push-proc)
  ;; This is mapped onto &AUX parameters.
  (dolist (parameter parameters)
    (multiple-value-bind (var value)
	(USER::PARSE-AUX-PARAMETER parameter)
      (funcall push-proc `(,var ,value)))))

;;;;;

(defun require-ample-macro-arguments (min max arglist lambda-list macro-name)
  (unless (listp arglist)
    (ferror "Attempt to bind lambda list ~S in macro ~S to ~S; a list is required."
	    lambda-list macro-name arglist))
  (let ((length (length arglist)))
    (cond
      ((< length min)
       (ferror "Too few arguments to lambda list ~S in macro ~S; ~S provided, ~S expected."
	       lambda-list macro-name length min))
      ((and max (> length max))
       (ferror "Too many arguments to lambda list ~S in macro ~S; ~S provided, ~S allowed."
	       lambda-list macro-name length max))
      (T
       NIL))))


;;; how to do this without gensymming macroform or macroenv
;;;
;`(let ((body #'(lambda () ,@body)))
;   (function (lambda (macroform macroenv)
;	       (funcall (lambda (,@(flatten-binding-list)) ,(funcall body))
;			,@(destructure macroform)
;			,@(include-macroform)
;			,@(include-macroenv)))))
;
;(flatten-binding-list blist)==> (var max resultform body)
;
;(destructure macroform) ==> (nth macroform 1()


;; "I am the ghost of SUBLIS-EVAL-ONCE1..."