;;; -*- Mode:Common-Lisp; Package:COMPILER; Base:10; Patch-file:T -*-

;;; Reason: Update the code walker to recognize the new special forms GENERIC-FLET and 
;;; GENERIC-LABELS.

;;;                           RESTRICTED RIGHTS LEGEND
;;;
;;; Use, duplication, or disclosure by the Government is subject to
;;; restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;; Technical Data and Computer Software clause at 52.227-7013.
;;;
;;;   TEXAS INSTRUMENTS INCORPORATED      
;;;   P.O. BOX 149149, M/S 2151             
;;;   AUSTIN, TEXAS 78714
;;;
;;; Copyright (C) 1989 Texas Instruments Incorporated.
;;; All rights reserved.

;;; Patch file for COMPILER version 6.9
;;; Written 07/11/89 13:40:18 by GRAY,
;;; while running on Kelvin from band LOD2
;;; With Inconsistent SYSTEM 6.11, VIRTUAL-MEMORY 6.1, EH 6.3, MAKE-SYSTEM 6.0, MICRONET 6.0,
;;;  LOCAL-FILE 6.0, BASIC-PATHNAME 6.1, NETWORK-SUPPORT-COLD 6.0, BASIC-NAMESPACE 6.1,
;;;  NETWORK-NAMESPACE 6.0, DISK-IO 6.0, DISK-LABEL 6.0, BASIC-FILE 6.2, MAC-PATHNAME 6.0,
;;;  NETWORK-PATHNAME 6.0, Inconsistent COMPILER 6.8, TV 6.12, DATALINK 6.0, CHAOSNET 6.0,
;;;  GC 6.3, MEMORY-AUX 6.0, NVRAM 6.1, SYSLOG 6.1, STREAMER-TAPE 6.4, UCL 6.0, INPUT-EDITOR 6.0,
;;;  METER 6.1, ZWEI 6.3, DEBUG-TOOLS 6.3, NETWORK-SUPPORT 6.0, NETWORK-SERVICE 6.1,
;;;  DATALINK-DISPLAYS 6.0, FONT-EDITOR 6.1, SERIAL 6.0, PRINTER 6.3, MAC-PRINTER-TYPES 6.1,
;;;  PRINTER-TYPES 6.1, IMAGEN 6.0, SUGGESTIONS 6.0, MAIL-DAEMON 6.2, MAIL-READER 6.1,
;;;  TELNET 6.0, VT100 6.0, NAMESPACE-EDITOR 6.0, PROFILE 6.1, VISIDOC 6.2, Inconsistent TI-CLOS 6.16,
;;;  CLEH 6.4, IP 3.47, Experimental BUG 11.10, Experimental CLX 6.2, CLUE 6.9, X11M 6.1,
;;;  Experimental DOCUMENTER 619.0,  microcode 429, Band Name: 6.0 SLE 6/5 + u429 6/8

;;; BUG REPORT NUMBER:  [none]
;;;
;;; PROBLEM:  Part of the implementation of CLOS which had not been done yet 
;;;	was to update the code walker to correctly handle the new special forms 
;;;	GENERIC-FLET and GENERIC-LABELS.  This would cause incorrect results if 
;;;	one of these forms was used in the body of a SYMBOL-MACROLET or 
;;;	WITH-SLOTS, and prevented MACROEXPAND-ALL from expanding macros within 
;;;	these forms.
;;;
;;; SOLUTION:  This patch implements code-walk handlers for GENERIC-FLET and 
;;;	GENERIC-LABELS.  [Handlers are not needed for GENERIC-FUNCTION and 
;;;	WITH-ADDED-METHODS because they are implemented as macros.]  This also 
;;;	required a modification to CW-SERIAL-BINDING to enable it to handle the 
;;;	specialized lambda lists of methods of local generic functions.
;;;
;;;	This patch also fixes a couple of related problems discovered during 
;;;	checkout of the new handlers:   The FLET and LABELS handlers are updated 
;;;	to not error on local SETF functions, and CW-EXPRESSION has been fixed to 
;;;	not invoke *CW-FUNCTION-HANDLER* on a FUNCTION forms referencing a local 
;;;	function.
;;;
;;; DEPENDENCIES:  Must be loaded after Compiler patch 6.5.

#!C
; From file WALKER.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; WALKER.#"


(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.
  ;;  7/11/89 DNG - Fix to not error on local (SETF ...) functions.
  (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))
		       when (symbolp (car elt)) ; only a symbol can name a macro
		       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))))
))

#!C
; From file WALKER.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; WALKER.#"



(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.
  ;;  7/11/89 DNG - Fix to not error on local (SETF ...) functions.
  (let* ((*local-functions* *local-functions*)
	 (cw-function-environment
	   (cons (loop for elt in (and (consp (second exp)) (second exp))
		       when (symbolp (car elt))
		       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))))

))

#!C
; From file WALKER.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; WALKER.#"


(defprop ticlos:generic-flet   cw-generic-flet cw-handler)
(defprop ticlos:generic-labels cw-generic-flet cw-handler)

(defun cw-generic-flet (form)
  ;;  7/11/89 DNG - Original.
  (flet ((cw-generic-flet-binding-list (bindlist)
	     (loop for elt in bindlist
		   collect
		   (list* (first elt)	; function name
			  (second elt)		; argument list
			  (loop for opt in (cddr elt)	; options
				collect
				(if (eq (car-safe opt) ':method)
				    (let ((new (copy-list opt)))
				      (do ((tail new (cdr tail)))
					  ((atom tail))
					(when (listp (car tail))
					  (let ((fn (cw-lambda-expression (cons 'lambda tail))))
					    (setf (car tail) (second fn))
					    (setf (cdr tail) (cddr fn)))
					  (return)))
				      new)
				  opt))))))
    (let* ((*local-functions* *local-functions*)
	   (bindlist (and (eq (car form) 'ticlos:generic-flet)	; not GENERIC-LABELS
			  (cw-generic-flet-binding-list (second form))))
	   (cw-function-environment
	     (cons (loop for elt in (and (consp (second form)) (second form))
			 when (symbolp (car elt))
			 nconc (list* (locf (symbol-function (car elt))) t nil))
		   cw-function-environment))
	   body)
      (dolist (elt (second form))
	(push (car elt) *local-functions*))
      (unless (eq (car form) 'ticlos:generic-flet) ; for GENERIC-LABELS
	(setq bindlist (cw-generic-flet-binding-list (second form))))
      (setq body (cw-clause (cddr form)))
      (if cw-return-expansion-flag
	  (list* (car form) bindlist body)))))
))

#!C
; From file WALKER.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; WALKER.#"


(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.
  ;;  7/11/89 DNG - Add use of NO-VALUE-P flag for handling methods of local generic functions.
  (when (consp bindlist)
    (when cw-return-expansion-flag
      (setq bindlist (mapcar #'copy-list bindlist)))
    (let ((no-value-p lambda-flag))
    (dolist (elt bindlist)
      (cond ((and lambda-flag (member elt lambda-list-keywords :test #'eq))
	     (when (member elt '(&optional &rest &key &aux &body) :test #'eq)
	       (setq no-value-p nil)))
	    ((or (symbolp elt)
		 (and (consp elt) (null (cdr elt)) (setq elt (car elt))))
	     (push elt *local-variables*))
	    ((atom elt))
	    ((consp elt)
	     (unless no-value-p ; for required argument of a CLOS method, 2nd element is class, not value.
	       (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)

))

#!C
; From file WALKER.LISP#> COMPILER; MR-X:
#10R COMPILER#:
(COMPILER-LET ((*PACKAGE* (FIND-PACKAGE "COMPILER"))
                          (SI:*LISP-MODE* :COMMON-LISP)
                          (*READTABLE* COMMON-LISP-READTABLE)
                          (SI:*READER-SYMBOL-SUBSTITUTIONS* SYS::*COMMON-LISP-SYMBOL-SUBSTITUTIONS*))
  (COMPILER#:PATCH-SOURCE-FILE "SYS: COMPILER; WALKER.#"


(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.
  ;;  6/22/89 DNG - Fix to include CW-EXTRA-ENVIRONMENT in the environment 
  ;;		passed to MACROEXPAND-1.  Also use WITH-INTERPRETER-ENVIRONMENT instead 
  ;;		of WITH-STACK-LIST*.
  ;;  7/11/89 DNG - Don't invoke *cw-function-handler* on a local function.
  (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 (unless (member (second exp) *local-functions* :test #'equal)
			   (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.
	     (sys:with-interpreter-environment (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)
	     (sys:with-interpreter-environment (env nil cw-function-environment cw-extra-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))))

))