;;; -*- Mode:LISP; Package:META-EVAL; Base:10 -*-

;;; GJC Some time in July 1980.
;;; a very simple meta evaluator for lisp code.
;;; the main use of this is for looking at functions
;;; which are candidates for open compilation.
;;; No. Also used to implement atomic macros in order to implement
;;; lexical DEFCLOSURE. Also used in the macsyma->lisp translator
;;; to gronk environments. Also used to implement lexicaly local macros...

;;; 9/06/84 23:40:17 Hacked to be a code walker for tail-recursion elimination.
;;; -gjc
;;; The hooks provided are also what Gary Drescher wanted for QLOGO.
;;; to be able to substitute for free variable references and to be
;;; able to modify certain function call references.

(defstruct (meta-var conc-name named (:Print "#<~:[~;special ~]var ~S>"
					     (meta-var-special-p meta-var)
					     (meta-var-name meta-var)))
  (eval-p 0)
  (setq-p 0)
  special-p
  name
  VALUE
  IN-LOOP-P       ;; T if found free a PROG context.
  IN-FUNARG-P
  CERTAIN-EVAL-P  ;; T if certain to get evaluated.
  ;; NIL if it might not get evaluated due to
  ;; RETURN, GO, or THROW.
  ORDER	;; the evaluation order of the first time evaluated.
  bound-p
  )

(defvar *meta-vars* nil)
(defvar *meta-vars-init* nil)

(defmacro def-meta-var (name value)
  `(progn 'compile
	 (defvar ,name ,value)
	 (enter-meta-var ',name)))

(defun enter-meta-var (name)
  (cond ((memq name *meta-vars*))
	(t
	 (push name *meta-vars*)
	 (push (symeval name) *meta-vars-init*)))
  name)

(def-meta-var *meta-var-stack* nil)
(DEF-META-VAR *META-BIND-STACK* NIL)
(def-meta-var *meta-var-eval-order-index* 0)
(DEF-meta-var *META-SUBST-P* NIL)
(DEF-META-VAR *META-FREE-VARS* NIL)
(DEF-META-VAR *META-CHECKING-FOR-FREE-VARS-P* NIL)
(DEF-META-VAR *META-IN-LOOP-CONTEXT-P* nil)
(DEF-META-VAR *META-IN-FUNARG-CONTEXT-P* NIL)
(DEF-META-VAR *META-IN-CERTAIN-EVAL-CONTEXT-P* T)

;; bound on each recursion by meta-eval-sub:
(defvar *meta-form* nil)
(defvar *meta-target* nil
  "meaning of values:
NIL meaning ignore value, eval for effect.
ARG meaning for an argument to another function.
RET meaning for return value of function")

;; an argument to toplevel meta-eval

(defvar *meta-application* nil "analogous to eval-hook")

(defun special-p (x)
  #+MACLISP
  (get x 'special)
  #+LISPM
  ;; this also arranges to find locally declared things within a file being compiled.
  (COMPILER:SPECIALP X))

;;; this is a system-dependant macro. In maclisp it only
;;; works in the compiler.
;;; Assuming: that the special declarations of variables are
;;; inherited in the local context. If this were not true then
;;; it would save a lot of hair and confusion, but it is true.

(defun meta-symeval (sym &aux (meta (get sym 'meta-var)))
  (COND ((EQ META 'BOUND) SYM)
	((AND META (META-VAR-BOUND-P META))
	 (META-VAR-NAME META))
	(META
	 ;; not interested in this variable otherwise.
	 (setq *meta-var-eval-order-index*
	       (1+ *meta-var-eval-order-index*))
	 (alter-meta-var meta
			 IN-LOOP-P *META-IN-LOOP-CONTEXT-P*
			 IN-FUNARG-P *META-IN-FUNARG-CONTEXT-P*
			 special-p (special-p sym)
			 eval-p (1+ (meta-var-eval-p meta))
			 CERTAIN-EVAL-P (OR (META-VAR-CERTAIN-EVAL-P META)
					    *META-IN-CERTAIN-EVAL-CONTEXT-P*)
			 order (or (meta-var-order meta)
				   *meta-var-eval-order-index*))
	 
	 (META-VAR-VALUE META))
	(*META-CHECKING-FOR-FREE-VARS-P*
	 ;; in this state we a looking for all free variables.
	 ;; so create a new cell for this one.
	 (setq *meta-var-eval-order-index* (1+ *meta-var-eval-order-index*))
	 (let ((cell (make-meta-var
		      IN-LOOP-P *meta-in-loop-context-p*
		      IN-FUNARG-P *META-IN-FUNARG-CONTEXT-P*
		      special-p (special-p sym)
		      name sym
		      eval-p 1
		      CERTAIN-EVAL-P *META-IN-CERTAIN-EVAL-CONTEXT-P*
		      order *meta-var-eval-order-index*)))
	   (setf (get sym 'meta-var) cell)
	   (push cell *meta-free-vars*)))
	(T SYM)))

(defun meta-set (sym)
  (or (symbolp sym)
      (meta-eval-error "Attempt to set non symbol" sym))
  (let ((meta (get sym 'meta-var)))
    (cond ((eq meta 'bound) sym)
	  ((AND META (META-VAR-BOUND-P META)) (META-VAR-NAME META))
	  (meta
	   (setf (meta-var-setq-p meta) (1+ (meta-var-setq-p meta)))
	   (or (meta-var-bound-p meta)
	       (setf (meta-var-special-p meta) (special-p sym)))
	   (meta-var-value meta))
	  (*meta-checking-for-free-vars-p*
	   (let ((cell (make-meta-var setq-p 1
				      value sym
				      special-p (special-p sym)
				      name sym)))
	     (setf (get sym 'Meta-var) cell)
	     (push cell *meta-free-vars*))
	   sym)
	  (t
	   sym))))

(DEFMACRO META-BINDV (VARL &REST BODY
			   &AUX (VARLG (GENSYM)))
  `(LET ((,VARLG ,VARL))
     (META-BINDPUSH ,VARLG)
     (UNWIND-PROTECT (PROGN ,@BODY)
		     (META-POPV ,VARLG))))

(DEFUN META-BINDPUSH (VARL)
  (MAPC #'(LAMBDA (V)
	    (OR (SYMBOLP V)
		(META-EVAL-ERROR "Attempt to bind non symbol" V))
	    (PUSH (GET V 'META-VAR) *META-VAR-STACK*)
	    (SETF (GET V 'META-VAR)
		  (IF *META-APPLICATION*
		      (MAKE-META-VAR NAME V
				     BOUND-P T
				     SPECIAL-P (SPECIAL-P V))
		    'BOUND))
	    (IF *META-APPLICATION*
		(PUSH (GET V 'META-VAR) *META-BIND-STACK*)))
	VARL))

(DEFUN META-POPV (VARL)
  (MAPC #'(LAMBDA (V)
	    (SETF (GET V 'META-VAR)
		  (POP *META-VAR-STACK*))
	    (IF *META-APPLICATION* (POP *META-BIND-STACK*)))
	VARL))


(DEFUN META-EVAL (FORM &OPTIONAL
		  (VARS NIL VARS-p)
		  (SUBST-LIST NIL SUBST-LIST-P)
		  *meta-application*)
"with one argument returns a list of free variables in the form.
with three arguments it substitutes for elements of <vars> the
cooresponding elements of the <subst-list>. The argument <*meta-application*>
gets called macro-like on each vanilla function application form
before the form is processed. The way to specify the target of evaluation
is by using the kludgy META-LET form, e.g.
 (meta-eval '(named-lambda foo () (meta-let ((*meta-target* 'ret)) (bar))))"

  (progv *meta-vars* *meta-vars-init*
    (or vars-p
	(setq *META-CHECKING-FOR-FREE-VARS-P* t))
    (and subst-list-P
	 (setq *meta-subst-p*
	       (or (= (length vars) (length subst-list))
		   (meta-eval-error
		     "In compatible var and subst-var lengths"	
		     (list vars subst-list)))))
    
    (META-BINDV
      VARS
      (UNWIND-PROTECT
	  (PROGN
	    (COND (*META-SUBST-P* 
		   (MAPC #'(LAMBDA (VAR VAL)
			     (SETF (GET VAR 'META-VAR)
				   (MAKE-META-VAR VALUE VAL
						  NAME VAR)))
			 VARS subst-list))
		  (*meta-checking-for-free-vars-p*)
		  (T
		   (MAPC #'(LAMBDA (V)
			     (SETF (GET V 'META-VAR)
				   (MAKE-META-VAR name v)))
			 VARS)))
	    (LET ((RESULT (META-EVAL-SUB FORM)))
	      (COND (*META-SUBST-P* RESULT)
		    (*meta-checking-for-free-vars-p*
		     *meta-free-vars*)
		    (t
		     (MAPCAR #'(LAMBDA (V) (GET V 'META-VAR)) VARS)))))
	(MAPC #'(LAMBDA (V)
		  (SETF (GET (META-VAR-NAME V) 'META-VAR) NIL))
	      *META-FREE-VARS*)))))

(DEFVAR *META-SPECIAL-FORMS* NIL)
;;; a self document.

(DEFMACRO DEFMETA-SPECIAL (NAME documentation &REST BODY)
  `(PROGN 'COMPILE
	  (defprop ,name ,documentation meta-documentation)
	  #+lispm (record-source-file-name ',name 'meta-special)
	  (DEFUN (,NAME META-EVAL) ()
	    ,@BODY)
	  (OR (MEMQ ',NAME *META-SPECIAL-FORMS*)
	      (PUSH ',NAME *META-SPECIAL-FORMS*))))

(DEFMACRO DEFMETA-PROP-SPECIAL (NAME PROP)
  `(PROGN 'COMPILE
	  (DEFPROP ,NAME ,PROP META-EVAL)
	  (OR (MEMQ ',NAME *META-SPECIAL-FORMS*)
	      (PUSH ',NAME *META-SPECIAL-FORMS*))))

(DEFUN META-EVAL-ERROR (message B)
  #+maclisp
  (ERROR (FORMAT NIL "~A encountered during meta evaluation." message)
	 B
	 'fail-act)
  #+lispm
  (ferror nil "~S ~A encountered during meta evaluation."  b message))

(DEFUN META-SPECIALP (OP &AUX (DISP (GET OP 'META-EVAL)))
  #+Maclisp
  (COND (DISP DISP)
	((GET OP 'MACRO)
	 #'(LAMBDA ()
	     (META-EVAL-SUB
	      (FUNCALL (GET (CAR *META-FORM*) 'MACRO) FORM)
	      *META-TARGET*)))
	((OR (GET OP 'SUBR)
	     (GET OP 'LSUBR)
	     (GET OP 'EXPR))
	 #'(lambda () (META-EVAL-ARGS-AND-APPLY *meta-form*)))
	((GET OP 'FSUBR)
	 (META-EVAL-ERROR "Unknown special form" OP))
	(T
	 #'(lambda () (META-EVAL-ARGS-AND-APPLY *meta-form*))))
  #+Lispm
  (COND (DISP DISP)
	((FBOUNDP OP)
	 (LET ((BINDING (FSYMEVAL OP)))
	   (COND ((FUNCTIONP OP)
		  #'(lambda () (META-EVAL-ARGS-AND-APPLY *meta-form*)))
		 ((AND (LISTP BINDING) (EQ (CAR BINDING) 'MACRO))
		  #'(LAMBDA ()
		      (META-EVAL-SUB
			(FUNCALL (CDR (FSYMEVAL (CAR *META-FORM*))) *META-FORM*)
			*META-TARGET*)))
		 ((FUNCTIONP OP T)
		  (META-EVAL-ERROR "Unknown special form" OP))
		 (T
		  (META-EVAL-ERROR "BUG: strange function kind?" op)))))
	(T
	 #'(lambda () (META-EVAL-ARGS-AND-APPLY *meta-form*)))))

(DEFUN META-EVAL-ARGS-AND-APPLY (FORM)
  "This is for anything that behaves just like a function call."
  (let ((new-form (if *meta-application*
		      (funcall *meta-application* form)
		    form)))
    (if (eq new-form form)
	(PROG1 (COND (*META-SUBST-P*
		      (CONS (CAR FORM) (META-EVAL-ARGS (CDR FORM))))
		     (T (META-EVAL-ARGS (CDR FORM))))
	       ;; here is where we need a real-live data base.
	       ;; there are whole classes of side-effects to think about.
	       (AND (FUNCTION-DOES-THROW-P (CAR FORM)) 
		    (SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL)))
      (meta-eval-sub new-form *meta-target*))))

(DEFUN FUNCTION-DOES-THROW-P (NAME)
  ;; well, meta-eval the function body and see!
  ;; Or, assume the worst about unknown functions.
  ;; That is the correct way to do it.
  ;; (I don't mention the assertion data-base one would need to
  ;; resolve circularities in unknown functions.)
  ;; for testing just assume no throwing around.
  (GET NAME 'THROW-P))

(DEFUN META-EVAL-ARGS (FORM)
  (COND (*META-SUBST-P*
	 (MAPCAR #'META-EVAL-SUB FORM))
	(T (MAPC #'META-EVAL-SUB  FORM))))

(DEFUN META-EVAL-EFFECT (FORM)
  (META-EVAL-SUB FORM NIL))

(DEFUN META-EVAL-ARG (FORM)
  (META-EVAL-SUB FORM 'ARG))

(DEFUN META-EVAL-RETURN (FORM)
  (META-EVAL-SUB FORM 'RET))

(DEFUN META-EVAL-SUB (*META-FORM* &OPTIONAL (*META-TARGET* 'ARG))
  (COND ((NULL *META-FORM*) *META-FORM*)
	((ATOM *META-FORM*)
	 (COND ((EQ T *META-FORM*) *META-FORM*)
	       ((SYMBOLP *META-FORM*)
		(META-SYMEVAL *META-FORM*))
	       (T *META-FORM*)))
	(T
	 (LET ((OP (CAR *META-FORM*)))
	   (COND ((ATOM OP)
		  (COND ((SYMBOLP OP)
			 (FUNCALL (META-SPECIALP OP)))
			(T
			 (META-EVAL-ERROR
			   "Non symbolic atom in operator position"
			   OP))))
		 ((EQ (CAR OP)'LAMBDA)
		  (let ((ARGS (META-EVAL-ARGS (CDR *meta-form*)))
			(OP (META-EVAL-FIXED-LAMBDA OP)))
		    (COND (*META-SUBST-P*
			   (CONS OP ARGS)))))
		 (T
		  (META-EVAL-ERROR
		    "Non-lambda expression in operator position"
		    OP)))))))


(DEFMETA-SPECIAL QUOTE "quote" *META-FORM*)

(defmeta-special function "foo"
  (OR (= (LENGTH *META-FORM*) 2)
      (META-EVAL-ERROR
	"Wrong number of args" *META-FORM*))
  (COND ((ATOM (CADR *META-FORM*)) *META-FORM*)
	((EQ (CAR (CADR *META-FORM*)) 'LAMBDA)
	 (LET ((RESULT (META-EVAL-SUB (CADR *META-FORM*))))
	   (COND (*META-SUBST-P*
		  (LIST (CAR *META-FORM*) RESULT)))))
	(T
	 (META-EVAL-ERROR
	   "Non-lambda expression in FUNCTION construct"
	   *META-FORM*))))

(DEFMETA-SPECIAL LAMBDA
		 "unfortunately not usually a special form but used by the above"
  (SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL)
  (LET ((*META-IN-FUNARG-CONTEXT-P* T)
	(*META-TARGET* 'ARG))
    (META-EVAL-FIXED-LAMBDA *META-FORM*)))

(DEFUN META-EVAL-FIXED-LAMBDA (*META-FORM*)
  ;; (LAMBDA ARGS . BODY)
  (COND ((CDR *META-FORM*)
	 (COND ((AND (CADR *META-FORM*) (ATOM (CADR *META-FORM*)))
		(META-EVAL-ERROR
		  "Bad lambda list internally" (cadr *META-FORM*)))
	       (T
		(LET ((BODY 
			(META-BINDV
			  (CADR *META-FORM*)
			  (META-EVAL-PROGN-ARGS (CDDR *META-FORM*) *META-TARGET*))))
		  (COND (*META-SUBST-P*
			 (LIST* (CAR *META-FORM*)
				(CADR *META-FORM*)
				BODY)))))))
	(T
	 (META-EVAL-ERROR
	   "Bad lambda expression" *META-FORM*))))

(DEFMETA-SPECIAL PROGN "progn"
  (CONS-PROGN (META-EVAL-PROGN-ARGS (CDR *META-FORM*) *META-TARGET*)))


(defun meta-eval-progn-args (l target &optional e-target)
  (IF (NULL L)
      NIL
    (do ((l l (cdr l))
	 (v nil (if *meta-subst-p*
		    (cons (meta-eval-sub (car l) e-target) v)
		  (meta-eval-sub (car l) e-target))))
	((null (cdr l))
	 (if *meta-subst-p*
	     (nconc (nreverse v) (list (meta-eval-sub (car l) target)))
	   (meta-eval-sub (Car l) target)))
      (meta-eval-sub (car l) target))))

(defun cons-progn (l)
  (if *meta-subst-p*
      (if (= 1 (length l))
	  (car l)
	(cons 'progn l))))

(DEFMETA-SPECIAL SETQ "setq"
  (DO ((ARGS (CDR *META-FORM*))
       (VAR)(VAL)
       (NEWBODY NIL))
      ((NULL ARGS)
       (COND (*META-SUBST-P*
	      ;; might as well turn it into a SETF
	      ;; this is a useful thing for atomic macros.
	      (CONS 'SETF (NREVERSE NEWBODY)))))
    (SETQ VAR (META-SET (POP ARGS)))
    (AND *META-SUBST-P* (PUSH VAR NEWBODY))
    (OR ARGS
	(META-EVAL-ERROR "Setq with odd number of arguments"
			 *META-FORM*))
    (SETQ VAL (META-EVAL-SUB (POP ARGS)))
    (AND *META-SUBST-P* (PUSH VAL NEWBODY))
    ))

(DEFMETA-SPECIAL PSETQ "moderate hair to keep as psetq if permissible"
  (let ((x (meta-eval-sub (cons 'setq (cdr *meta-form*)) *meta-target*)))
    (if *meta-subst-p*
	(do ((l (cdr x) (cddr l)))
	    ((null l)
	     (cons 'psetq (cdr x)))
	  (or (atom (car l))
	      (meta-eval-error "can't hack this in psetq yet" (Car l)))))))

(DEFUN VAR-OF-LET-PAIR (LET-PAIR)
  ;; LET-PAIR can be  FOO or (FOO) or (FOO BAR)
  (COND ((ATOM LET-PAIR) LET-PAIR)
	(T (CAR LET-PAIR))))

(DEFUN CODE-OF-LET-PAIR (LET-PAIR)
  (COND ((ATOM LET-PAIR) NIL)
	((NULL (CDR LET-PAIR)) NIL)
	(T (CADR LET-PAIR))))

(DEFMETA-SPECIAL META-LET "a kludge like compiler-let, for hacking internals during meta-eval"
  (DO ((LET-PAIRS (CADR *META-FORM*) (CDR LET-PAIRS))
       (BODY `(PROGN ,@(CDDR *META-FORM*)))
       (VARS NIL (CONS (VAR-OF-LET-PAIR (CAR LET-PAIRS)) VARS))
       (VALS NIL
	     (CONS (EVAL (CODE-OF-LET-PAIR (CAR LET-PAIRS))) VALS)))
      ((NULL LET-PAIRS)
       (PROGV VARS
	      VALS
	 (META-EVAL-SUB BODY *meta-target*)))))

(DEFMETA-SPECIAL COMPILER-LET "have to do this too though"
  (DO ((LET-PAIRS (CADR *META-FORM*) (CDR LET-PAIRS))
       (BODY (CDDR *META-FORM*))
       (VARS NIL (CONS (VAR-OF-LET-PAIR (CAR LET-PAIRS)) VARS))
       (VALS NIL
	     (CONS (EVAL (CODE-OF-LET-PAIR (CAR LET-PAIRS))) VALS)))
      ((NULL LET-PAIRS)
       (PROGV VARS
	      VALS
	 (CONSI 'COMPILER-LET (CONSI (CADR *META-FORM*)
				     (META-EVAL-PROGN-ARGS BODY *meta-target*)))))))

(defvar *prog-target* nil)

(DEFMETA-SPECIAL PROG "maclisp prog, no hair"
  (let ((*meta-in-loop-context-p* *meta-in-loop-context-p*)
	(*prog-target* *meta-target*))
    ;; We go along evaluating the forms in the prog.
    ;; Our state changes if we see a TAG, a GO, or a RETURN.
    (COND ((CDR *META-FORM*)
	   (COND ((AND (CADR *META-FORM*) (ATOM (CADR *META-FORM*)))
		  (META-EVAL-ERROR
		    "Bad PROG var list" (CADR *META-FORM*)))
		 (T
		  (META-BINDV
		    (CADR *META-FORM*)
		    (COND (*META-SUBST-P*
			   `(PROG ,(CADR *META-FORM*)
				  ,@(MAPCAR
				      #'(LAMBDA
					  (U)
					  (COND ((ATOM U)
						 (SETQ *META-IN-LOOP-CONTEXT-P* T)
						 U)
						(T
						 (META-EVAL-EFFECT U))))
				      (CDDR *META-FORM*))))
			  (T
			   (MAPC #'(LAMBDA (U)
				     (COND ((ATOM U)
					    (SETQ *META-IN-LOOP-CONTEXT-P* T))
					   (T
					    (META-EVAL-EFFECT U))))
				 (CDDR *META-FORM*))))))
		 (T
		  (META-EVAL-ERROR "Bad PROG" *META-FORM*)))))))

(DEFMETA-SPECIAL GO "go for it"
  (PROG1
    (COND ((CDR *META-FORM*)
	   (COND ((ATOM (CADR *META-FORM*)) *META-FORM*)
		 (T
		  (META-EVAL-ARGS-AND-APPLY *META-FORM*))))
	  (T
	   (META-EVAL-ERROR "Bad GO form" *META-FORM*)))
    (SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL)))

(DEFMETA-SPECIAL RETURN "return"
  (PROG1 (LISTI 'RETURN (META-EVAL-SUB (CADR *META-FORM*) *PROG-TARGET*))
	 (SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL)))


(DEFUN LISTI (&REST L)
  (IF *META-SUBST-P* (COPYLIST L)))

;; we generate return-from in progitor, although named-progs are not
;; handled. sigh. just pass it through.
(DEFMETA-SPECIAL RETURN-FROM ""
  (LET ((L (META-EVAL-ARGS (CDDR *META-FORM*))))
    (IF *META-SUBST-P*
	(LIST* (CAR *META-FORM*) (CADR *META-FORM*) L))))

(DEFMETA-SPECIAL COMMENT ""
  *META-FORM*)

(DEFUN CONSI (A B)
  (IF *META-SUBST-P* (CONS A B)))

(DEFUN META-EVAL-AND-OR-ARGS (ARGS)
  (META-EVAL-PROGN-ARGS ARGS *META-TARGET* 'ARG))

(DEFUN META-EVAL-AND-OR ()
  (CONSI (CAR *META-FORM*) (META-EVAL-AND-OR-ARGS (CDR *META-FORM*))))


(DEFMETA-PROP-SPECIAL AND META-EVAL-AND-OR)
(DEFMETA-PROP-SPECIAL OR META-EVAL-AND-OR)

(DEFMETA-SPECIAL COND "hairy maclisp cond"
  (DO ((FORMS (CDR *META-FORM*) (CDR FORMS))
       (PRED)(BODY)
       (CLAUSE) (NEWBODY))
      ((NULL FORMS)
       (COND (*META-SUBST-P*
	      `(COND ,@(NREVERSE NEWBODY)))))
    (AND (ATOM (CAR FORMS))
	 (META-EVAL-ERROR "Bad COND clause" (CAR FORMS)))
    ;; will side-effect *META-IN-CERTAIN-EVAL-CONTEXT-P*
    (SETQ CLAUSE (CAR FORMS))
    (COND ((AND (NULL (CDR FORMS)) CLAUSE (NULL (CDR CLAUSE)))
	   ;; last form in cond special case.
	   (SETQ PRED (META-EVAL-SUB (CAR CLAUSE) *META-TARGET*)
		 BODY NIL))
	  (T
	   (SETQ PRED (META-EVAL-SUB (CAR CLAUSE))
		 BODY (META-EVAL-PROGN-ARGS (CDR CLAUSE) *META-TARGET*))))
    (AND *META-SUBST-P*
	 (PUSH (CONS PRED BODY) NEWBODY))))


(DEFMETA-SPECIAL DEFUN "bad"
  (META-EVAL-ERROR "DEFUN in the middle of code" *META-FORM*))

(DEFMETA-SPECIAL EVAL-WHEN "bad"
  (META-EVAL-ERROR "EVAL-WHEN inside code" *META-FORM*))

(DEFMETA-SPECIAL DECLARE "this is it"
  (mapc #'(lambda
	    (dform)
	    (cond ((atom dform))
		  ((eq (car dform) 'special)
		   (mapc #'(lambda
			     (var)
			     (cond ((atom var)
				    (let ((meta
					    (get var 'meta-var)))
				      (cond ((eq meta 'bound))
					    (meta
					     (setf (meta-var-special-p meta)
						   t))
					    (*META-CHECKING-FOR-FREE-VARS-P*
					     ;; a local declaration for
					     ;; a global variable?
					     ;; poo-poo.
					     nil)
					    (t nil))))))
			 (cdr dform)))))
	(cdr *meta-form*))
 (COND (*META-SUBST-P*
	(CONS 'DECLARE
	      (MAPCAR #'META-EVAL-ARGS-AND-APPLY
		      (CDR *META-FORM*))))))

(DEFUN META-ARGSCHK (MIN &OPTIONAL (MAX MIN))
  (LET ((N (1- (LENGTH *META-FORM*))))
    (OR (<= MIN N MAX)
	(META-EVAL-ERROR "Wrong number of args in form" *META-FORM*))))

(DEFMETA-SPECIAL STORE ""
  (meta-argschk 2 6.)
  (CONSI 'STORE (META-EVAL-ARGS (CDR *META-FORM*))))


(DEFUN LIKE-A-FUNCTION-CALL ()
  "Like a function call, but a really special form"
  (CONSI (CAR *META-FORM*) (META-EVAL-ARGS-AND-APPLY (CDR *META-FORM*))))

(DEFMETA-PROP-SPECIAL *CATCH LIKE-A-FUNCTION-CALL)
(DEFMETA-PROP-SPECIAL *THROW LIKE-A-FUNCTION-CALL)

(DEFMETA-PROP-SPECIAL CATCHALL LIKE-A-FUNCTION-CALL)
(DEFMETA-PROP-SPECIAL CATCH-BARRIER LIKE-A-FUNCTION-CALL)
(DEFMETA-PROP-SPECIAL UNWIND-PROTECT LIKE-A-FUNCTION-CALL)

(DEFMETA-PROP-SPECIAL PROGV LIKE-A-FUNCTION-CALL)

(defconst DO-NULL-SLOT '%%%DO-NULL-SLOT%%%)

(DEFUN DO-INIT-FORM-META-CHECK (U)
  (COND ((OR (NULL U) (ATOM U))
	 (META-EVAL-ERROR
	   "Bad DO var iterate form" U))
	((CDR U)
	 (META-EVAL-SUB (CADR U)))
	(T
	 DO-NULL-SLOT)))

(DEFUN DO-ITER-FORM-META-CHECK (U)
  (COND ((NULL (CDDR U)) DO-NULL-SLOT)
	(T (META-EVAL-SUB (CADDR U)))))

(DEFMETA-SPECIAL DO "(DO (<FORML>) ...)"
  (let ((*meta-in-loop-context-p* *META-IN-LOOP-CONTEXT-P*)
	(*prog-target* *meta-target*))
    (OR (> (LENGTH *META-FORM*) 2)
	(META-EVAL-ERROR "Bad DO form" *META-FORM*))
    (AND (CADR *META-FORM*)
	 (ATOM (CADR *META-FORM*))
	 (META-EVAL-ERROR "Bad DO var list" (CADR *META-FORM*)))
    (LET (INIT-FORMS ITER-FORMS VARS ENDFORMS BODY)
      (COND (*META-SUBST-P*
	     (SETQ INIT-FORMS
		   (MAPCAR #'DO-INIT-FORM-META-CHECK
			   (CADR *META-FORM*))))
	    (T (MAPC #'DO-INIT-FORM-META-CHECK (CADR *META-FORM*))))
      (SETQ VARS (MAPCAR #'CAR (CADR *META-FORM*)))
      (META-BINDV
	VARS
	(SETQ *META-IN-LOOP-CONTEXT-P* T)
	(AND (OR (NULL (CADDR *META-FORM*))
		 (ATOM (CADDR *META-FORM*)))
	     (META-EVAL-ERROR "Bad end clause in DO"
			      (CADDR *META-FORM*)))
	
	(SETQ ENDFORMS (CADDR *META-FORM*))
	(SETQ ENDFORMS (CONS (META-EVAL-SUB (CAR ENDFORMS))
			     (META-EVAL-PROGN-ARGS (CDR ENDFORMS) *META-TARGET*)))
	(COND (*META-SUBST-P*
	       (SETQ ITER-FORMS
		     (MAPCAR #'DO-ITER-FORM-META-CHECK
			     (CADR *META-FORM*))))
	      (T (MAPC #'DO-ITER-FORM-META-CHECK
		       (CADR *META-FORM*))))
	(SETQ BODY (META-EVAL-PROGN-ARGS (CDDDR *META-FORM*) NIL)))
      (COND (*META-SUBST-P*
	     `(DO ,(MAPCAR
		     #'(LAMBDA (VAR INIT ITER)
			 (COND ((EQ INIT
				    DO-NULL-SLOT)
				(LIST VAR))
			       ((EQ ITER
				    DO-NULL-SLOT)
				(LIST VAR INIT))
			       (T
				(LIST VAR INIT ITER))))
		     VARS INIT-FORMS ITER-FORMS)
		  ,ENDFORMS
		,@BODY))))))


(DEFMETA-SPECIAL SIGNP "(SIGNP C X)"
  (OR (= (LENGTH *META-FORM*) 3)
      (ERROR "Wrong number of args to SIGNP" *META-FORM*))
  (LET ((RES (META-EVAL-SUB (CADDR *META-FORM*))))
    (COND (*META-SUBST-P*
	   (LIST 'SIGNP (CADR *META-FORM*) RES)))))

; this next are new fsubrs. which have macro properties in the compiler.

(DEFUN CASEQ-META-EVAL (CASE)
  (COND ((ATOM CASE)
	 (META-EVAL-ERROR "Bad CASEQ clause" CASE))
	(*META-SUBST-P*
	 (CONS (CAR CASE) (META-EVAL-ARGS (CDR CASE))))
	(T (META-EVAL-ARGS (CDR CASE)))))

(DEFMETA-SPECIAL CASEQ ""
  (OR (CDR *META-FORM*)
      (META-EVAL-ERROR "Bad CASEQ form" *META-FORM*))
  (LET ((CASEQ (META-EVAL-SUB (CADR *META-FORM*))))
    (SETQ *META-IN-CERTAIN-EVAL-CONTEXT-P* NIL)
    (COND (*META-SUBST-P*
	   (LIST* 'CASEQ CASEQ
		  (MAPCAR #'CASEQ-META-EVAL
			  (CDDR *META-FORM*))))
	  (T
	   (MAPC #'CASEQ-META-EVAL
		 (CDDR *META-FORM*))))))



(DEFUN TEST-APPLICATION-FUNCTION (FORM)
  (print (list *meta-target* form))
  form)


(defun test-body-eval (expression)
  "meta-evaluate expression as if it were the body of a function"
  (let ((vars (meta-eval expression)))
    (let ((var-names (mapcar 'meta-var-name vars)))
      (meta-eval `(meta-let ((*meta-target* 'ret))
			    ,expression)
		 var-names
		 var-names
		 'test-application-function))))


;; other examples:

(defvar *progitor-function* ())
(defvar *progitor-args* ())
(defvar *progitor-need-prog? nil)
(defvar *progitor-tail-escape* nil)

(defun progitor (a-defun)
  (let ((*progitor-function* (cadr a-defun))
	(*progitor-args* (caddr a-defun))
	(*progitor-need-prog? nil)
	(body `(progn ,@(cdddr a-defun)))
	(*progitor-tail-escape* (intern (string-append (cadr a-defun) "-tail-escape"))))
    (let ((new-body (meta-eval `(meta-let ((*meta-target* 'ret)) ,body)
			       ()
			       ()
			       'progitor-application-hook)))
      (if *progitor-need-prog?
	  (values `(defun ,*progitor-function* ,*progitor-args*
		     (tagbody
		      loop
			 (block ,*progitor-tail-escape*
			   (return-from ,*progitor-function* ,new-body))
			 (go loop)))
		  *progitor-need-prog?)
	    a-defun))))

(defconst *progitor-debug? nil)

(defun progitor-application-hook (form)
  (if *progitor-debug?
      (format t "~&Evaluating ~s for ~A value"
	      form *meta-target*))
  (cond ((and (eq *meta-target* 'ret)
	      (eq (car form) *progitor-function*)
	      (do ((l *meta-BIND-stack* (cdr l)))
		  ((null l) t)
		(and (meta-var-special-p (car l)) (return nil))))
	 (setq *progitor-need-prog? (if *progitor-need-prog?
					(1+ *progitor-need-prog?)
				      1))
	 `(progn ,(CONS-psetq (mapcan #'list
				      *progitor-args*
				      (cdr form)))
		 (return-from ,*progitor-tail-escape*)))
	('else
	 form)))

(DEFUN CONS-PSETQ (L)
  (AND L (CONS 'PSETQ L)))

(defmacro defmeta-macro (op doc &body body)
  `(defmeta-special ,op ,doc
     (meta-eval-sub (progn ,@body) *meta-target*)))


(DEFUN MAPI (F &REST L)
  (LEXPR-FUNCALL 
    (IF *META-SUBST-P* #'MAPCAR #'MAPC)
    F L))

(defmeta-SPECIAL let "used to be a macro"
  (LET ((VARS (mapcar #'var-of-let-pair (cadr *meta-form*)))
	(VALS (MAPI #'(LAMBDA (X) (META-EVAL-SUB (CODE-OF-LET-PAIR X))) (CADR *META-FORM*))))
    (CONSI 'LET
	   (CONSI (MAPI #'LISTI VARS VALS)
		  (META-BINDV VARS
			      (META-EVAL-PROGN-ARGS (CDDR *META-FORM*) *META-TARGET*))))))

(defmeta-macro if "(if pred a b)"
  `(cond (,(cadr *meta-form*)
	  ,(caddr *meta-form*))
	 (t
	  (progn ,@(cdddr *meta-form*)))))


(DEFUN PROGITEST (&QUOTE FORM)
  (EVAL FORM)
  (EVAL `(GRINDEF ,(CADR FORM)))
  (EVAL (PROGITOR FORM))
  (EVAL `(GRINDEF ,(CADR FORM)))
  (COMPILE (CADR FORM))
  (DISASSEMBLE (CADR FORM)))

(defmeta-special variable-location "yow"
  (listi 'variable-location
	 (meta-symeval (cadr *meta-form*))))


(defmeta-special the "(the type value)"
  (listi 'the
	 (cadr *meta-form*)
	 (meta-eval-sub (caddr *meta-form*)
			*meta-target*)))