;;;    -*- Mode:Common-Lisp; Package:Compiler; Base:10 -*-
	
;;;                           RESTRICTED RIGHTS LEGEND

;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;                     TEXAS INSTRUMENTS INCORPORATED.
;;;                              P.O. BOX 2909
;;;                           AUSTIN, TEXAS 78769
;;;                                 MS 2151
;;;
;;; Copyright (C) 1984,1988 Texas Instruments Incorporated. All rights reserved.
;;; Copyright (C) 1980 Massachusetts Institute of Technology


;;; Code walker for the compiler.
;;; Find out all variables referenced free by a piece of code,
;;; all lexical functions that it uses free,
;;; all BLOCK names the code tries to return to but doesn't catch,
;;; all GO tags the code tries to GO to but doesn't define.


;;; Feb. 1984 - Version 98 from MIT via LMI.
;;; 08/01/84 DNG - Incorporate changes from MIT patches 98.31 (binding lists),
;;;            98.33 (understand &QUOTE arglists and add DEFPROP for CW-HANDLER
;;;            of a bunch of additional functions), 98.39 (variants of LET),
;;;            and 98.47 (IF).
;;; 09/17/84 DNG - Update documentation strings for CW-TOP-LEVEL and 
;;;            CW-TOP-LEVEL-LAMBDA-EXPRESSION from MIT patch 98.33.
;;; 07/09/85 DNG - Fix CW-LAMBDA-EXPRESSION to recognize CLI:LAMBDA etc.
;;; 11/12/85 DNG - Provide MACROEXPAND-ALL handler for DEFUN, DEFSUBST, and DEFMACRO.
;;;  3/10/86 DNG - File "SYS;QCLUKE" renamed to "COMPILER;WALKER";
;;;		add handler for THE.
;;;  4/06/86 DNG - Converted from Zetalisp to Common Lisp.
;;;  5/21/86 DNG - Moved function MEXP to this file since it uses MACROEXPAND-ALL.
;;;  6/09/86 DNG - Eliminated use of DELQ.
;;;  6/11/86 DNG - Use CW-EVAL-ARGS for [LEXPR-]FUNCALL-WITH-MAPPING-TABLE[-INTERNAL].
;;;  6/17/86 DNG - Define handler for *THROW.
;;;  6/21/86 DNG - Eliminated use of MEMQ and ASSQ.
;;;  9/30/86 DNG - No longer need handlers for PROG[*] (now a macro) or SI:ADVISE-... (no longer used).
;;; 11/21/86 DNG - Remove handlers for COMMENT, DEFUN, DEFSUBST, DEFMACRO, and 
;;;		MACRO since these are now macros instead of special forms.
;;; 12/31/86 DNG - Fix CW-LAMBDA-EXPRESSION to handle macros.
;;;  1/22/87 DNG - Update MACROLET handler to call MAKE-EXPANDER-FUNCTION instead of EXPAND-DEFMACRO.
;;;  1/28/87 DNG - Fix CW-EXPRESSION for local macro as argument of another local macro. [SPR 3088]
;;;  1/28/87 DNG - Fix CW-MULTIPLE-VALUE to not lose destination vars that are locally bound. 
;;;  2/11/87 DNG - Use CW-EVAL-ARGS for CATCH and *CATCH.
;;;------------------ Above in release 3; the following for release 4.0 ------
;;; 12/11/87 DNG - Update CW-EXPRESSION and (:PROPERTY FUNCTION CW-HANDLER) to 
;;;		permit returning a list of all functions referenced.  [needed by Documenter utility]
;;;------------------ The following for release 6.0 ---------
;;;  4/26/88 DNG - Re-designed around new interface CODE-WALK.  This enables 
;;;		use by the macro SYMBOL-MACROLET and also simplifies the code and makes 
;;;		existing uses of the code walker more efficient.
;;;  9/20/88 DNG - Update SYMBOL-MACROLET to permit declarations.
;;; 10/05/88 DNG - Replace use of obsolete functions COPYLIST and FSYMEVAL.
;;; 12/01/88 DNG - Fixed scoping bug in handling next-value expressions of DO.
;;;  2/01/89 DNG - Add handler for LOAD-TIME-VALUE .
;;;  4/11/89 DNG - Added use of variable CW-EXTRA-ENVIRONMENT.

(defvar cw-function-environment)
(defparameter cw-extra-environment nil)
(defvar cw-return-expansion-flag)

(defparameter *cw-form-handler* #'identity)
(defparameter *cw-var-handler* #'identity)
(defparameter *cw-function-handler* #'identity)
(defparameter *cw-go-handler* #'identity)
(defparameter *cw-return-handler* #'identity)

(defparameter *local-variables* '())
(defparameter *local-functions* '())
(defparameter *local-go-tags* '())
(defparameter *local-blocks* '())

(defun code-walk (form form-fn var-fn &optional return-expansion-p environment
		  &key function go return)
  "Code walker.  The arguments are a Lisp FORM to be examined and functions to 
be called on appropriate portions of the form.  Each of the functions can 
either return its argument for scanning of its sub-forms or can return a 
substitute form to be used instead. Note that inapplicable function arguments 
should be specified as #'IDENTITY.
FORM-FN is a function to be called on each sub-form which is an
	invocation of a non-local function, macro, or special form.	
VAR-FN is a function to be called on each free variable reference.
:FUNCTION is a function to be called on each FUNCTION form which
	references a non-local function.
:GO is a function to be called on each non-local GO form.
:RETURN is a function to be called on each non-local RETURN or RETURN-FROM.
RETURN-EXPANSION-P when true, causes the new form created by any substitution 
	and macro expansion to be returned as the result value of CODE-WALK.  
	Otherwise, CODE-WALK returns no values.
ENVIRONMENT is a macro expansion environment object obtained from the 
	&environment parameter of a macro. "
  ;;  4/26/88 DNG - Original version.
  ;;  4/11/89 DNG - Add binding of CW-EXTRA-ENVIRONMENT.
  (let ((cw-function-environment (env-functions environment))
	(cw-extra-environment (env-extra environment))
	(cw-return-expansion-flag return-expansion-p)
	(*cw-form-handler* form-fn)
	(*cw-var-handler* var-fn)
	(*cw-function-handler* (or function #'identity))
	(*local-variables* '())
	(*local-functions* '())
	(*local-go-tags* '())
	(*local-blocks* '())
	(*cw-return-handler* (or return #'identity))
	(*cw-go-handler* (or go #'identity))
	result
	)
    (setq result (cw-expression form))
    (if return-expansion-p
	result
      ;; else result is not meaningful
      (values)) ))

(defvar all-block-names)
(defvar all-go-tags)
(defvar all-functions-to-check-for)
(defvar all-functions)
(defvar all-variables-to-check-for)
(defvar all-variables)

(defun macroexpand-all (form &optional environment)
  "Expand macro calls at all levels in FORM, and return the result.
ENVIRONMENT specifies which local MACROLET macro definitions are in effect.
It is like the second argument to MACROEXPAND."
  ;;  4/25/88 DNG - Redesigned to use CODE-WALK instead of CW-TOP-LEVEL.
  (code-walk form #'identity #'identity t environment))

(defun cw-top-level (exp &optional all-variables-to-check-for
		     all-functions-to-check-for cw-function-environment
		     cw-return-expansion-flag)
   "Return a list of free variables, block names and go tags used by expression EXP.
CW-FUNCTION-ENVIRONMENT has the same format as SI:INTERPRETER-FUNCTION-ENVIRONMENT.
 It is used to record local macros available
 and local function definitions that may be shadowing global macro definitions.
CW-RETURN-EXPANSION-FLAG if non-NIL says expand macros to all levels
 and construct a macro-free form, returned as the fifth value.
The first value lists the free variables,
 (but only symbols present in the argument ALL-VARIABLES-TO-CHECK-FOR are mentioned),
the second lists function symbols used free
 (but only symbols present in the argument ALL-FUNCTIONS-TO-CHECK-FOR are mentioned),
the third value lists the free block names (including possibly NIL),
the fourth lists the free go tags.
the fifth is the macroexpanded form, but only if CW-RETURN-EXPANSION-FLAG is non-NIL.
ALL-VARIABLES-to-CHECK-FOR or ALL-FUNCTIONS-TO-CHECK-FOR may also be T, 
meaning return all variables or functions used free."
  ;;  4/25/88 DNG - Redesigned to use CODE-WALK.
  (declare (unspecial cw-return-expansion-flag cw-function-environment))
  (declare (values variables functions block-names go-tags macroexpanded-form))
  (let (all-variables all-functions all-block-names all-go-tags exp-value)
    (setq exp-value
	  (code-walk exp
		     #'(lambda (form)
			 (when (and (debug-assert (and (consp form)
						       (symbolp (car form))))
				    (or (eq all-functions-to-check-for t)
					(member (car form) all-functions-to-check-for
						:test #'eq)))
			   (pushnew (car form) all-functions :test #'eq))
			 form)
		     #'(lambda (var)
			 (when (and (debug-assert (symbolp var))
				    (or (eq all-variables-to-check-for t)
					(member var all-variables-to-check-for :test #'eq)))
			   (pushnew var all-variables :test #'eq))
			 var)
		     cw-return-expansion-flag
		     (list '() cw-function-environment)
		     :function #'(lambda (form)
				   (when (and (debug-assert (and (consp form)
								 (eq (first form) 'function)))
					      (function-spec-p (second form))
					      (or (eq all-functions-to-check-for t)
						  (member (second form) all-functions-to-check-for
							  :test #'equal)))
				     (pushnew (second form) all-functions :test #'equal))
				   form)
		     :go #'(lambda (form)
			     (pushnew (second form) all-go-tags :test #'eql)
			     form)
		     :return #'(lambda (form)
				 (let ((block (if (eq (first form) 'return)
						  'nil
						(second form))))
				   (pushnew block all-block-names :test #'eq))
				 form)
		     ))
    (values all-variables all-functions all-block-names all-go-tags
	    exp-value)))

(defun cw-top-level-lambda-expression (exp &rest options)
  "Return a list of free variables, block names and go tags used by expression EXP.
CW-FUNCTION-ENVIRONMENT has the same format as SI:INTERPRETER-FUNCTION-ENVIRONMENT.
 It is used to record local macros available
 and local function definitions that may be shadowing global macro definitions.
CW-RETURN-EXPANSION-FLAG if non-NIL says expand macros to all levels
 and construct a macro-free form, returned as the fifth value.
The first value lists the free variables,
 (but only symbols present in the argument ALL-VARIABLES-TO-CHECK-FOR are mentioned),
the second lists function symbols used free
 (but only symbols present in the argument ALL-FUNCTIONS-TO-CHECK-FOR are mentioned),
the third value lists the free block names (including possibly NIL),
the fourth lists the free go tags.
the fifth is the macroexpanded form, but only if CW-RETURN-EXPANSION-FLAG is non-NIL.
ALL-VARIABLES-to-CHECK-FOR may also be T, meaning return all variables used free."
  ;;  4/25/88 DNG - Redesigned to use CODE-WALK.
  (declare (arglist exp &optional all-variables-to-check-for
		    all-functions-to-check-for cw-function-environment
		    cw-return-expansion-flag))
  (declare (values variables functions block-names go-tags macroexpanded-lambda-exp))
  (with-stack-list (form 'function exp)
    (multiple-value-bind (variables functions block-names go-tags macroexpanded-lambda-exp)
	(apply #'cw-top-level form options)
      (when (eq (car-safe macroexpanded-lambda-exp) 'function)
	(setf macroexpanded-lambda-exp
	      (second macroexpanded-lambda-exp)))
      (values variables functions block-names go-tags macroexpanded-lambda-exp))))

(DEFUN MEXP (&OPTIONAL FORM &AUX EXP)
  "Read-macroexpand-print loop, for seeing how macros expand.
MEXP reads s-expressions and macroexpands each one, printing the expansion.
Type NIL to exit (or ABORT)."
    (DO-FOREVER
      (UNLESS FORM
	(FORMAT T "~2%Macro form ")
	(SEND *STANDARD-INPUT* :UNTYI (SEND *STANDARD-INPUT* :TYI)));Allow abort to exit
      (CATCH-ERROR-RESTART ((SYS:ABORT ERROR) "Return to MEXP input loop.")
	(SETQ EXP (OR FORM (READ-FOR-TOP-LEVEL)))
	(AND (SYMBOLP EXP) (RETURN NIL))
	(DO ((LAST NIL EXP))
	    ((EQ EXP LAST))
	  (SETQ EXP (MACROEXPAND-1 EXP))
	  (PRINC "  ")
	  (PPRINT EXP))
	(UNLESS (EQUAL EXP (SETQ EXP (MACROEXPAND-ALL EXP)))
	  (PRINC "  ")
	  (PPRINT EXP)))
      (WHEN FORM (RETURN (VALUES))) ))

(defmacro ticlos:symbol-macrolet (bindings &body body &environment env)
  "Syntax:  SYMBOL-MACROLET ({(symbol expansion)}*) &BODY body
Replaces each occurrence of SYMBOL as a free variable in BODY with its 
corresponding EXPANSION.  Also changes SETQ to SETF when necessary.
Declarations are permitted at the front of the body."
  (declare (arglist bindings &body body))
  ;;  4/26/88 DNG - Original version.
  ;;  9/14/88 DNG - Add support for declarations.
  ;; 11/23/88 DNG - Fix for (SETF (VALUES ...) ...).
  ;;  4/18/89 DNG - Extend to support MULTIPLE-VALUE-SETQ. (this feature 
  ;;		adopted by X3J13, March 1989)
  (if (null bindings)
      `(locally . ,body)
    ;; First find and process any type declarations that refer to the 
    ;; variables being declared.
    (multiple-value-bind (body decls)
	(parse-body body env nil)
      (let ((other-decls '()))
	(flet ((record-type (type vars)
		 (dolist (v vars)
		   (let ((tem (assoc v bindings :test #'eq)))
		     (if tem
			 (push (list v `(the ,type ,(second tem)))
			       bindings)
		       (push `(type ,type ,v) other-decls))))))
	  (dolist (declare decls)
	    (debug-assert (eq (first declare) 'declare))
	    (dolist (decl (cdr declare))
	      (if (eq (first decl) 'type)
		  (record-type (second decl) (cddr decl))
		(if (standard-type-name-P (first decl) t)
		    (record-type (first decl) (rest decl))
		  (progn
		    (when (eq (first decl) 'special)
		      (dolist (v (rest decl))
			(when (assoc v bindings :test #'eq)
			  (error "(DECLARE (SPECIAL ~S)) is not permitted in ~S."
				 v 'ticlos:symbol-macrolet))))
		    (push decl other-decls)))))))
	;; Now scan the body, making substitutions where needed.
	(code-walk (cond (other-decls `(locally (declare . ,(nreverse other-decls))
						. ,body))
			 ((cdr body) `(progn . ,body))
			 (t (first body)))
		   #'(lambda (form)
		       (case (car form)
			 (SETQ (do ((tail (cdr form) (cddr tail)))
				   ((null tail) form)
				 (let ((tem (assoc (car tail) bindings :test #'eq)))
				   (when (and tem (not (symbolp (second tem))))
				     ;; Need to change SETQ to SETF.  Can't just return
				     ;; `(SETF .,(CDR FORM)) because SETF would expand
				     ;; back into a SETQ and we would hang in a loop.
				     (return (values `(setf . ,(mapcar #'cw-expression
								       (cdr form)))
						     t)) ))))
			 ;; Avoid macro-expanding SETF so that it doesn't change
			 ;; back into a SETQ or MULTIPLE-VALUE-SETQ.
			 (SETF (values `(setf . ,(mapcar #'cw-expression
							 (cdr form)))
				       t))
			 (MULTIPLE-VALUE-SETQ
			   (dolist (a (second form) form)
			      (when (assoc a bindings :test #'eq)
				 (return `(setf (values . ,(mapcar #'cw-expression (second form)))
						  . ,(cddr form))))))
			 (t form)))
		   #'(lambda (var)
		       (let ((tem (assoc var bindings :test #'eq)))
			 (if tem
			     (values (second tem) t)
			   var)))
		   t
		   env)))))


(comment -- old way without allowing declarations
(defmacro ticlos:symbol-macrolet (bindings &body body &environment env)
  "Syntax:  SYMBOL-MACROLET ((symbol expansion)*) &BODY body
Replaces each occurrence of SYMBOL as a free variable in BODY with its 
corresponding EXPANSION.  Also changes SETQ to SETF when necessary."
  ;;  4/26/88 DNG - Original version.
  (let ((form (if (cdr body)
		  `(progn . ,body)
		(first body))))
    (if (null bindings)
	form
      (code-walk form
		 #'(lambda (form)
		     (if (eq (car form) 'setq)
			 (do ((tail (cdr form) (cddr tail)))
			     ((null tail) form)
			   (let ((tem (assoc (car tail) bindings :test #'eq)))
			     (when (and tem (not (symbolp (second tem))))
			       ;; Need to change SETQ to SETF.  Can't just return
			       ;; `(SETF .,(CDR FORM)) because SETF would expand
			       ;; back into a SETQ and we would hang in a loop.
			       (return (values `(setf . ,(mapcar #'cw-expression
								 (cdr form)))
					       t)) )))
		       form))
		 #'(lambda (var)
		     (let ((tem (assoc var bindings :test #'eq)))
		       (if tem
			   (values (second tem) t)
			 var)))
		 t
		 env))))
)

(defsubst cw-clause (clause)
  (funcall (if cw-return-expansion-flag #'mapcar #'mapc)
	   #'cw-expression clause))

(defsubst cw-eval-args (exp)
  (if cw-return-expansion-flag
      (cons (car exp) (mapcar #'cw-expression (cdr exp)))
    (mapc #'cw-expression (cdr exp))))

(defsubst cw-first-arg-quoted (exp)
  (if cw-return-expansion-flag
      (list* (car exp) (cadr exp) (mapcar #'cw-expression (cddr exp)))
    (mapc #'cw-expression (cddr exp))))

(defun cw-expression (exp &optional skip-handler &aux tem stop)
  ;; 10/18/86 DNG - Use si:args-desc instead of arglist to check for &quote args.
  ;;  1/28/87 DNG - Don't bind cw-function-environment to nil when expanding a local macro. [SPR 3088]
  ;; 12/11/87 DNG - Allow ALL-FUNCTIONS-TO-CHECK-FOR to be T to cause all to be returned.
  ;;		Modify update of ALL-FUNCTIONS to check for (SYMBOLP (CAR EXP))
  ;;		and use :TEST #'EQ for efficiency.
  ;;		Add :TEST #'EQ to the second PUSHNEW call for efficiency.
  ;;  4/26/88 DNG - Updated to support new interface function CODE-WALK.
  ;;  3/15/89 DNG - Use GET-FROM-FRAME-LIST.
  ;;  4/11/89 DNG - Add use of CW-EXTRA-ENVIRONMENT .
  ;;  4/18/89 DNG - Add use of WARN-ON-ERRORS; this is needed within SYMBOL-MACROLET.
  (typecase exp
    (symbol (unless (or (null exp)
			skip-handler
			(member exp *local-variables* :test #'eq))
	      (multiple-value-setq (exp stop)
		(funcall *cw-var-handler* exp))))
    (cons (unless (or skip-handler
		      (not (symbolp (car exp)))
		      (member (car exp) *local-functions* :test #'eq))
	    (case (car exp)
	      ( quote )
	      ( function (multiple-value-setq (exp stop)
			   (funcall *cw-function-handler* exp)))
	      ( t (unless (eq *cw-form-handler* #'identity)
		    (multiple-value-setq (exp stop)
		      (funcall *cw-form-handler* exp))))) )))
  (cond ((or (atom exp) stop)
	 exp)
	((consp (car exp))
	 ;; Explicit lambda-expression
	 (if cw-return-expansion-flag
	     (cons (cw-lambda-expression (car exp))
		   (mapcar #'cw-expression (cdr exp)))
	   (progn (cw-lambda-expression (car exp))
		  (mapc #'cw-expression (cdr exp)))))
	((nsymbolp (car exp))
	 (cw-eval-args exp))
	((setq tem (get-from-frame-list (locf (symbol-function (car exp)))
					cw-function-environment nil))
	 (if (eq (car-safe tem) 'macro)
	     ;; Local definition is a macro.  Call its expander.
	     (with-stack-list* (si:*macroexpand-environment*
				 nil cw-function-environment cw-extra-environment)
	       (cw-expression (funcall (cdr tem) exp
				       si:*macroexpand-environment*)))
	   ;; Local definition is not a macro.  Assume it evals its args.
	   (cw-eval-args exp)))
	((setq tem (get (car exp) 'cw-handler))
	 ;; special form with its own way of doing this.
	 (funcall tem exp))
	;;kludge to deal with &quote. Blech
	((and (fboundp (car exp))
	      (nth-value 3 (si:args-desc (car exp))))
	 (let ((quoted nil)
	       (tem (arglist (car exp) t)))
	   (flet ((frob (arg) (do ((x (pop tem) (pop tem)))
				  ((not (member x lambda-list-keywords :test #'eq))
				   (if quoted arg (cw-expression arg)))
				(cond ((eq x '&quote) (setq quoted t))
				      ((eq x '&eval) (setq quoted nil))))))
	     (if cw-return-expansion-flag
		 (cons (car exp) (mapcar #'frob (cdr exp)))
	       (mapc #'frob (cdr exp))))))
	((multiple-value-bind (v1 v2)
	     (with-stack-list (env nil cw-function-environment)
	       (if (eq (second (first eh:*condition-handlers*))
		       'warn-on-errors-condition-handler)
		   ;; If already within the WARN-ON-ERRORS in PRE-OPTIMIZE, need to handle 
		   ;; errors here so they get reported accurately instead of having 
		   ;; PRE-OPTIMIZE report a problem with the top-level macro.
		   (block warn
		     (WARN-ON-ERRORS ('MACRO-EXPANSION-ERROR "Error expanding macro ~S:" (car exp))
		       (return-from warn (macroexpand-1 exp env)))
		     ;; here if there was an error.
		     (return-from cw-expression `(ERROR-MACRO-EXPANDING ',exp)))
		 (macroexpand-1 exp env)))
	   (setq tem v1)
	   v2)
	 ;; Macro call.
	 (cw-expression tem))
	(t
	 (cw-eval-args exp))))

(defun cw-lambda-expression (exp)
  ;;  7/08/85 DNG - Fixed to recognize CLI:[NAMED-]LAMBDA as well as
  ;;                GLOBAL:[NAMED-]LAMBDA.
  ;;  7/22/86 DNG - Don't call CW-EXPRESSION on a function spec.
  ;; 12/31/86 DNG - Fix to handle (MACRO . (LAMBDA ...)).
  ;;  4/25/88 DNG - Modified for use with CODE-WALK.
  (let ((*local-variables* *local-variables*))
    (cond ((member (car exp) '(global:lambda global:subst cli:lambda cli:subst) :test #'eq)
	   (let* ((expansion (cw-serial-binding (second exp) t))
		  (body-expansion (cw-clause (cddr exp))))
	     (if cw-return-expansion-flag
		 (list* (car exp)
			expansion
			body-expansion))))
	  ((member (car exp) '(global:named-lambda global:named-subst
						   named-lambda    named-subst)
		   :test #'eq)
	   (let* ((expansion (cw-serial-binding (third exp) t))
		  (body-expansion (cw-clause (cdddr exp))))
	     (if cw-return-expansion-flag
		 (list* (first exp)
			(second exp)
			expansion
			body-expansion))))
	  ((eq (car exp) 'macro)
	   (if cw-return-expansion-flag
	       (cons 'macro (cw-lambda-expression (cdr exp)))
	     (cw-lambda-expression (cdr exp))))
	  ((lambda-macro-call-p exp)
	   (cw-lambda-expression
	     (lambda-macro-expand exp)))
	  ((validate-function-spec exp)
	   exp)
	  (t
	   ;; This is something invalid which will get a warning later.
	   (cw-expression exp)))))

(defun cw-serial-binding (bindlist &optional lambda-flag)
  "Return a list of variables bound by BINDLIST, while recording any variables it uses free.
This is for serial binding such as is found in LAMBDAs and PROG*'s.
LAMBDA-FLAG should be T for a LAMBDA arglist, otherwise NIL.
Second value is an expansion of the bindlist, if one is requested."
  ;;  4/25/88 DNG - Redesigned for use with CODE-WALK.
  ;; 12/01/88 DNG - Fix so next-value expression of DO* is within the current binding.
  (when (consp bindlist)
    (when cw-return-expansion-flag
      (setq bindlist (mapcar #'copy-list bindlist)))
    (dolist (elt bindlist)
      (cond ((and lambda-flag (member elt lambda-list-keywords :test #'eq)))
	    ((or (symbolp elt)
		 (and (consp elt) (null (cdr elt)) (setq elt (car elt))))
	     (push elt *local-variables*))
	    ((atom elt))
	    ((consp elt)
	     (if cw-return-expansion-flag
		 (setf (second elt) (cw-expression (second elt)))
	       (cw-expression (second elt)))
	     (push (car elt) *local-variables*)
	     (if lambda-flag
		 ;; elt is (var default-value supplied-flag)
		 (when (third elt)
		   (push (third elt) *local-variables*))
	       ;; here for processing DO bindings
	       (do ((tail (cddr elt) (cdr tail)))
		   ((null tail))
		 (if cw-return-expansion-flag
		     (setf (car tail) (cw-expression (car tail)))
		   (cw-expression (car tail)))))))))
  bindlist)

(defun cw-parallel-binding (bindlist)
  "Return a list of variables bound by BINDLIST and update *LOCAL-VARIABLES*.
This is for parallel binding such as is found in PROG and LET."
  ;;  4/25/88 DNG - Redesigned for use with CODE-WALK.
  ;; 12/01/88 DNG - Fix so next-value expression of DO is within the current binding.
  (declare (values expansion))
  (when (consp bindlist)
    (let ((bound '()))
      (when cw-return-expansion-flag
	(setq bindlist (mapcar #'copy-list bindlist)))
      (dolist (elt bindlist)
	(cond ((or (symbolp elt)
		   (and (consp elt) (null (cdr elt)) (setq elt (car elt))))
	       (push elt bound))
	      ((atom elt))
	      ((consp elt)
	       (if cw-return-expansion-flag
		   (setf (second elt)
			 (cw-expression (second elt)))
		 (cw-expression (second elt)))
	       (push (if (consp (car elt))
			 (second (car elt))
		       (car elt))
		     bound)
	       (unless (null (cddr elt))
		 ;; next-value expression of DO is within associated binding.
		 (let ((*local-variables* (cons (first bound) *local-variables*)))
		   (do ((tail (cddr elt) (cdr tail)))
		       ((null tail))
		     (if cw-return-expansion-flag
			 (setf (car tail) (cw-expression (car tail)))
		       (cw-expression (car tail)))))) )))
      (setq *local-variables* (nconc bound *local-variables*)) ))
  bindlist)

;;; Variable-binding constructs which don't contain go tags.

(defprop let cw-let cw-handler)
(defun cw-let (exp)
  ;;  4/25/88 DNG - Redesigned for use with CODE-WALK.
  (let* ((*local-variables* *local-variables*)
	 (bindlist (cw-parallel-binding (second exp)))
	 (body (cw-clause (cddr exp))))
    (and cw-return-expansion-flag
	 (list* (car exp) bindlist body))))

(defun (:property let* cw-handler) (exp)
  ;;  4/25/88 DNG - Redesigned for use with CODE-WALK.
  (let* ((*local-variables* *local-variables*)
	 (bindlist (cw-serial-binding (second exp)))
	 (body (cw-clause (cddr exp))))
    (and cw-return-expansion-flag
	 (list* (car exp) bindlist body))))

(defun (:property multiple-value-bind cw-handler) (exp)
  ;;  4/25/88 DNG - Redesigned for use with CODE-WALK.
  (let* ((mvform (cw-expression (third exp)))
	 (*local-variables* (append (second exp) *local-variables*))
	 (body (cw-clause (cdddr exp))))
    (and cw-return-expansion-flag
	 (list* 'multiple-value-bind (second exp) mvform body))))

(defprop with-stack-list cw-with-stack-list cw-handler)
(defprop with-stack-list* cw-with-stack-list cw-handler)

(defun cw-with-stack-list (exp)
  ;;  4/25/88 DNG - Redesigned for use with CODE-WALK.
  (let* ((elements (cw-clause (cdadr exp)))
	 (var (caadr exp))
	 (*local-variables* (cons var *local-variables*))
	 (body (cw-clause (cddr exp))))
    (and cw-return-expansion-flag
	 (list* (car exp) (cons var elements) body))))

(defun (:property compiler-let cw-handler) (exp)
  (progw (second exp)
    (cw-first-arg-quoted exp)))

(defun (:property let-if cw-handler) (exp)
  ;;  4/25/88 DNG - Redesigned for use with CODE-WALK.
  (let* ((cond (cw-expression (second exp)))
	 (*local-variables* *local-variables*)
	 (bindlist (cw-parallel-binding (third exp)))
	 (body (cw-clause (cdddr exp))))
    (and cw-return-expansion-flag
	 (list* (car exp) cond bindlist body))))

(defprop and cw-eval-args cw-handler)
(defprop or cw-eval-args cw-handler)
(defprop setq cw-eval-args cw-handler)
(defprop login-setq cw-eval-args cw-handler)
(defprop progn cw-eval-args cw-handler)
(defprop progv cw-eval-args cw-handler)
(defprop progw cw-eval-args cw-handler)
(defprop unwind-protect cw-eval-args cw-handler)
(defprop dont-optimize cw-eval-args cw-handler)
(defprop eval-when cw-first-arg-quoted cw-handler)
(defprop multiple-value-list cw-eval-args cw-handler)
(defprop nth-value cw-eval-args cw-handler)
(defprop throw cw-eval-args cw-handler)
(defprop *throw cw-eval-args cw-handler)
(defprop catch cw-eval-args cw-handler)
(defprop *catch cw-eval-args cw-handler)
(defprop si:setq-if-unbound cw-eval-args cw-handler)
(defprop patch-source-file cw-first-arg-quoted cw-handler)
(defprop si:defvar-1 cw-first-arg-quoted cw-handler)
(defprop si:*catch-for-eval cw-eval-args cw-handler)
(defprop the cw-first-arg-quoted cw-handler)
(defun (:property si:matchcarcdr cw-handler) (exp)
  (let ((arg (cw-expression (second exp)))
	(car (cw-lambda-expression (third exp)))
	(cdr (cw-lambda-expression (fourth exp))))
    (if cw-return-expansion-flag `(si:matchcarcdr ,arg ,car ,cdr))))

(defprop       funcall-with-mapping-table	   cw-eval-args	cw-handler)
(defprop       funcall-with-mapping-table-internal cw-eval-args	cw-handler)
(defprop lexpr-funcall-with-mapping-table	   cw-eval-args	cw-handler)
(defprop lexpr-funcall-with-mapping-table-internal cw-eval-args cw-handler)

;; PROG, DO, GO, RETURN, RETURN-FROM, TAGBODY.

(defun cw-prog-body (body)
  ;;  4/26/88
  (dolist (elt body)
    (when (atom elt) (push elt *local-go-tags*)))
  (funcall (if cw-return-expansion-flag #'mapcar #'mapc)
	   #'(lambda (statement)
	       (if (atom statement) statement (cw-expression statement)))
	   body))

(defun (:property tagbody cw-handler) (exp)
  ;;  4/26/88
  (let ((*local-go-tags* *local-go-tags*))
    (cons 'tagbody (cw-prog-body (cdr exp)))))

(defun (:property do cw-handler) (exp)
  (cw-do-form exp #'cw-parallel-binding))

(defun (:property do* cw-handler) (exp)
  (cw-do-form exp #'cw-serial-binding))

(defun (:property do-named cw-handler) (exp)
  (cons (car exp) (cw-do-form (cdr exp) #'cw-parallel-binding (second exp))))

(defun (:property do*-named cw-handler) (exp)
  (cons (car exp) (cw-do-form (cdr exp) #'cw-serial-binding (second exp))))

(defun cw-do-form (exp binding-list-function &optional progname)
  ;;  4/26/88
  (let ((*local-variables* *local-variables*)
	(*local-go-tags* *local-go-tags*)
	(*local-blocks* (cons 'nil *local-blocks*)))
    (when progname (push progname *local-blocks*))
    (if (and (second exp) (symbolp (second exp)))
	;; old-style DO
	(let ((var (second exp))
	      vars ival step test altered-body)
	  (setq ival (cw-expression (third exp)))	;initial value expression
	  (push var *local-variables*)
	  (setq step (cw-expression (fourth exp)))	;Step expression
	  (setq test (cw-expression (fifth exp)))	;Endtest
	  (setq altered-body (cw-prog-body (nthcdr 5 exp)))
	  (if cw-return-expansion-flag
	      (list* (car exp) var ival step test altered-body)))
      (let ((varlist (second exp)) (endstuff (third exp)) (body (cdddr exp))
	     vars altered-body altered-endstuff)
	(let ((bindlist (funcall binding-list-function varlist)))
	  (setq altered-endstuff (cw-clause endstuff))
	  (setq altered-body (cw-prog-body body))
	  (if cw-return-expansion-flag
	      (list* (car exp) bindlist altered-endstuff altered-body)))))))

(defun (:property go cw-handler) (exp)
  ;;  4/26/88
  (if (member (second exp) *local-go-tags* :test #'eql)
      exp
    ;; Invoke user-defined handler for non-local transfer of control.
    (multiple-value-bind (new stop)
	(funcall *cw-go-handler* exp)
      (if (or (eq new exp) stop)
	  new
	(cw-expression new)))))

(defun (:property return-from cw-handler) (exp)
  ;;  4/26/88
  (if (member (second exp) *local-blocks* :test #'eq)
      (cw-first-arg-quoted exp)
    ;; Invoke user-defined handler for non-local transfer of control.
    (multiple-value-bind (new stop)
	(funcall *cw-return-handler* exp)
      (cond ((eq new exp)
	     (cw-first-arg-quoted exp))
	    (stop new)
	    (t (cw-expression new))))))

(defun (:property return cw-handler) (exp)
  ;;  4/26/88
  (if (member 'nil *local-blocks* :test #'eq)
      (cw-eval-args exp)
    ;; Invoke user-defined handler for non-local transfer of control.
    (multiple-value-bind (new stop)
	(funcall *cw-return-handler* exp)
      (cond ((eq new exp)
	     (cw-eval-args exp))
	    (stop new)
	    (t (cw-expression new))))))

(defun (:property block cw-handler) (exp)
  ;;  4/26/88
  (let ((*local-blocks* (cons (second exp) *local-blocks*)))
    (cw-first-arg-quoted exp)))

(defprop quote identity cw-handler)

(defun (:property function cw-handler) (exp)
  ;;  7/22/86 DNG - Don't call CW-LAMBDA-EXPRESSION on a non-symbol function spec. 
  ;; 12/11/87 DNG - Allow ALL-FUNCTIONS-TO-CHECK-FOR to be T to cause all to be returned.
  ;;  4/25/88 DNG - Modified for use with CODE-WALK and to fix SPR 7842.
  (let ((fn (second exp)))
    (if (consp fn)
	(if (and (symbolp (car fn))
		 (get (car fn) 'function-spec-handler))	; a function spec
	    exp
	  ;; else should be a lambda expression
	  (if cw-return-expansion-flag
	      (list 'function (cw-lambda-expression fn))
	    (cw-lambda-expression fn)))
      exp)))

(defun (:property cond cw-handler) (exp)
  (if cw-return-expansion-flag
      (cons 'cond (mapcar #'cw-clause (cdr exp)))
    (mapc #'cw-clause (cdr exp))))

(defprop if cw-eval-args cw-handler)

(defprop multiple-value cw-multiple-value cw-handler)
(defprop multiple-value-setq cw-multiple-value cw-handler)
(defprop multiple-value-call cw-eval-args cw-handler)
(defprop multiple-value-prog1 cw-eval-args cw-handler)

(defun cw-multiple-value (exp)
  ;;  4/25/88 DNG - Redesigned for use with CODE-WALK.
  (if cw-return-expansion-flag
      (list* (first exp)
	     (mapcar #'cw-expression (second exp))
	     (mapcar #'cw-expression (cddr exp)))
    (progn (mapc #'cw-expression (second exp))
	   (mapc #'cw-expression (cddr exp)))))

(defprop declare identity cw-handler)

(defprop with-self-accessible cw-first-arg-quoted cw-handler)

(defprop quote-eval-at-load-time identity cw-handler)

(deff cw-quoted-variable-expression 'cw-eval-args)
(defprop variable-boundp cw-quoted-variable-expression cw-handler)
(defprop variable-location cw-quoted-variable-expression cw-handler)
(defprop variable-makunbound cw-quoted-variable-expression cw-handler)

(defprop boundp cw-eval-args cw-handler)
(defprop value-cell-location cw-eval-args cw-handler)


(defun cw-flet-binding-list (bindlist)
  (if cw-return-expansion-flag
      (loop for elt in bindlist
	    collect (cons (car elt)
			  (cdr (cw-lambda-expression (cons 'lambda (cdr elt))))))
    (dolist (elt bindlist)
      (cw-lambda-expression (cons 'lambda (cdr elt))))))

(defun (:property flet cw-handler) (exp)
  ;;  4/25/88 DNG - Redesigned for use with CODE-WALK.
  ;;  4/20/89 DNG - Record definition as T instead of NIL to reduce confusion with undefined function.
  (let* ((*local-functions* *local-functions*)
	 (bindlist (cw-flet-binding-list (second exp)))
	 (cw-function-environment
	   (cons (loop for elt in (and (consp (second exp)) (second exp))
		       nconc (list* (locf (symbol-function (car elt))) t nil))
		 cw-function-environment))
	 body)
    (dolist (elt (second exp))
      (push (car elt) *local-functions*))
    (setq body (cw-clause (cddr exp)))
    (if cw-return-expansion-flag
	(list* 'flet bindlist body))))

(defun (:property macrolet cw-handler) (exp)
  ;;  1/22/87 - Call MAKE-EXPANDER-FUNCTION instead of EXPAND-DEFMACRO .
  (let ((*local-functions* *local-functions*)
	(cw-function-environment
	  (cons (loop for elt in (and (consp (second exp)) (second exp))
		      nconc (list* (locf (symbol-function (car elt)))
				   (cons 'macro (si:make-expander-function elt))
				   nil))
		cw-function-environment)))
    (dolist (elt (second exp))
      (push (car elt) *local-functions*))
    (let ((body (cw-clause (cddr exp))))
      (when cw-return-expansion-flag
	;; No need to have a MACROLET in the result
	;; since there cannot be any uses of the local macros remaining after expansion.
	(if (= (length body) 1)
	    (car body)
	  (cons 'progn body))))))

(defun (:property labels cw-handler) (exp)
  ;;  4/25/88 DNG - Redesigned for use with CODE-WALK.
  ;;  4/20/89 DNG - Record definition as T instead of NIL to reduce confusion with undefined function.
  (let* ((*local-functions* *local-functions*)
	 (cw-function-environment
	   (cons (loop for elt in (and (consp (second exp)) (second exp))
		       nconc (list* (locf (symbol-function (car elt))) t nil))
		 cw-function-environment))
	 bindlist body)
    (dolist (elt (second exp))
      (push (car elt) *local-functions*))
    (setq bindlist (cw-flet-binding-list (second exp)))
    (setq body (cw-clause (cddr exp)))
    (if cw-return-expansion-flag
	(list* 'labels bindlist body))))

;; The following two added 12/17/88
(defprop p1-has-been-done identity cw-handler)
(defprop SYS::%MAKE-CLOS-CONTINUATION-LIST identity cw-handler)

;; added 2/1/89
(defprop load-time-value identity cw-handler) ; don't macroexpand this until it is evaluated.