;;; -*- 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)
	(SI::GOBBLE-DECLARATIONS body T NIL)  ;make this last argument env when macroexpand works.
      (when doc-string (push `(DOCUMENTATION ,doc-string) decls))
      `(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-for-nested-lambda-list (lambda-list path push-proc macro-form macro-env)
  (let ((index 0))
    (flet 
      (
       
       ;; This is mapped onto required parameters.
       (make-binding-or-recurse (var)
	 (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))))
	   
       ;; This is mapped onto &OPTIONAL parameters.
       (do-optional-variable (parameter)
	 (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)))

       ;; This is mapped onto &KEY parameters.
       (do-key-parameter (parameter)
	 (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))))))))

       ;; This is mapped onto &AUX parameters.
       (do-aux-parameter (parameter)
	 (multiple-value-bind (var value)
	     (USER::PARSE-AUX-PARAMETER parameter)
	   (funcall push-proc `(,var ,value))))
       
       )
	   
      ;; 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))))))

      ;; Parse it
      (multiple-value-bind (required optional rest key allow aux body whole environment)
	  (user::moby-parse-lambda-list lambda-list)

	;; Make a dummy binding that checks for ample arguments
	(let ((min-args (length required))
	      (max-args (if (or rest key aux whole) NIL (+ (length required) (length optional)))))
	  (funcall push-proc `(IGNORE (REQUIRE-AMPLE-MACRO-ARGUMENTS 
					,min-args ,max-args ,path ',lambda-list (CAR ,macro-form)))))

	;; Make a binding for the &WHOLE variable, if present
	(when whole
	  (funcall push-proc `(,whole ,macro-form)))
	
	;; Make a binding for the &ENVIRONMENT variable, if present
	(when environment
	  (funcall push-proc `(,environment ,macro-env)))
	
	;; Make bindings for the required parameters
	(mapcar #'make-binding-or-recurse required)
	
	;; Make bindings for the &OPTIONAL parameters
	(mapcar #'do-optional-variable optional)
	
	;; Make a binding for the &REST or &BODY parameter, if present
	(when (or rest body)
	  (funcall push-proc `(,(if rest rest body) (NTHCDR ,index ,path))))
	
	;; Make bindings for the &KEY parameters
	(mapcar #'do-key-parameter key)
	
	;; Ignore the &ALLOW-OTHER-KEYS business entirely
	allow

	;; Make bindings for the &AUX parameters
	(mapcar #'do-aux-parameter aux)))))


(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..."