;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.112
;;; Reason:
;;;  Minor cosmetic changes to cross compiler warnings.
;;; Written 18-Oct-88 10:18:13 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 3
;;; with Experimental System 126.108, Experimental ZWEI 126.19, Experimental ZMail 74.9, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Lambda-Diag 18.0, Experimental Unix-Interface 15.0, Experimental Tape 26.4, Experimental IMicro 20.0, microcode 1762, SDU Boot Tape 3.14, SDU ROM 103.


; From modified file DJ: L.SYS; QFCTNS.LISP#858 at 18-Oct-88 15:42:55
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFCTNS  "

(defun expand-macro-call (macro-call environment expand-substs &key inhibitor macro-function-finder)
  (declare (values expansion expanded-flag))
  (if (atom macro-call) macro-call
    (let ((name (car macro-call))
	  (out-of-this-world nil))
      (cond ((not (atom name))
	     (cond ((eq (caar macro-call) 'curry-after)
		    (values `(,(cadar macro-call) ,@(cdr macro-call) . ,(cddar macro-call))
			    t))
		   ((eq (caar macro-call) 'curry-before)
		    (values `(,(cadar macro-call) ,@(cddar macro-call) . ,(cdr macro-call))
			    t))
		   ;; Have to ignore EXPAND-SUBSTS here since compiler can't deal with ((SUBST ...) ...)
		   ((memq (caar macro-call) '(subst cli:subst named-subst))
		    (values (funcall *macroexpand-hook* 'subst-expand-1 macro-call environment)
			    t))
		   (t macro-call)))
	    ((not (symbolp name)) macro-call)
	    (t
	     (let ((tm (fsymeval-in-environment name environment nil)))
	       (cond (tm ; local definition
		      (if (eq (car-safe tm) 'macro)
			  (call-macro-expander (cdr tm) macro-call environment)
			macro-call))
		     ;; Possibly inhibit macro expansion.
		     ((and inhibitor (funcall inhibitor name)) macro-call)
		     ((and macro-function-finder (setq tm (funcall macro-function-finder name)))
		      (record-macro-expanded name)
		      (values (call-macro-expander tm macro-call environment)
			      t))
		     (t
		      (multiple-value-setq (tm out-of-this-world) (declared-definition name))
		      (cond ((typep tm 'compiled-function)	; Possible compiler-defined subst
			     (if expand-substs
				 (if out-of-this-world		;||| Cross compiler ignores native SUBSTs - 14oct smh
				     (progn
				       #+never	;||| smh 18oct88
				       (compiler:warn 'cross-compilation :NOT-PORTABLE
					 "Cross compilation for ~a ignoring ~s subst definition from ~a host."
					 compiler:*target-computer* name compiler:*host-computer*)
				       macro-call)
				   (progn
				     ;; If function is compiled, see if its interpreted defn is recorded.
				     (setq tm (assq 'interpreted-definition (debugging-info tm)))
				     (if (and tm (memq (caadr tm) '(subst cli:subst named-subst)))
					 (progn
					   (record-macro-expanded name)
					   (values (funcall *macroexpand-hook* 'subst-expand-1 macro-call environment)
						   t))
				       macro-call)))			       
			       macro-call))
			    ((atom tm) macro-call) ; ordinary function
			    ((eq (car tm) 'macro)
			     (when out-of-this-world
			       (compiler:warn 'cross-compilation :NOT-PORTABLE
				 "Cross compilation for ~a taking ~s macro definition from ~a host."
				 compiler:*target-computer* name compiler:*host-computer*))
			     (record-macro-expanded name)
			     (values (call-macro-expander (cdr tm) macro-call environment) t))
			    ((memq (car tm) '(subst cli:subst named-subst)) ; interpreter-defined SUBST
			     (if expand-substs
				 (if out-of-this-world		;||| Cross compiler ignores native SUBSTs - 14oct smh
				     (progn
				       #+never	;||| smh 18oct88
				       (compiler:warn 'cross-compilation :NOT-PORTABLE
					 "Cross compilation for ~a ignoring ~s subst definition from ~a host."
					 compiler:*target-computer* name compiler:*host-computer*)
				       macro-call)
				   (progn
				     (record-macro-expanded name)
				     (values (funcall *macroexpand-hook* 'subst-expand-1 macro-call environment)
					     t)))
			       macro-call))
			    (t macro-call)))
		     (t macro-call))))))))

))