;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.97
;;; Reason:
;;;  More changes to macro expansion and declared-definition in
;;;  support of cross compilation.  SHould not affect native lambda
;;;  compilation.
;;; Written 29-Sep-88 16:35:56 by smh at site Gigamos Cambridge
;;; while running on Alex from band 3
;;; with Experimental System 126.95, Experimental ZWEI 126.14, Experimental ZMail 74.2, Experimental Local-File 76.0, Experimental File-Server 25.0, Experimental Lambda-Diag 18.0, Experimental Unix-Interface 15.0, Experimental Tape 26.4, microcode 1762, SDU Boot Tape 3.14, SDU ROM 102, Lambda/Falcon Development System.



; From modified file DJ: L.SYS; QFCTNS.LISP#856 at 29-Sep-88 16:36:10
#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
				 (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
					 (when out-of-this-world
					   (compiler:warn 'cross-compilation :NOT-PORTABLE
					     "Cross compilation for ~s taking ~s macro definition from ~s host."
					     compiler:*target-computer* name compiler:*host-computer*))
					 (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 ~s taking ~s macro definition from ~s 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
				 (progn
				   (when out-of-this-world
				     (compiler:warn 'cross-compilation :NOT-PORTABLE
				       "Cross compilation for ~s taking ~s macro definition from ~s host."
				       compiler:*target-computer* name compiler:*host-computer*))
				   (record-macro-expanded name)
				   (values (funcall *macroexpand-hook* 'subst-expand-1 macro-call environment)
					   t))
			       macro-call))
			    (t macro-call)))
		     (t macro-call))))))))

))

; From modified file DJ: L.SYS; QFCTNS.LISP#856 at 29-Sep-88 16:36:14
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFCTNS  "

  
(defun macroexpand-1 (macro-call &optional environment)
  "Expand MACRO-CALL once and return the result.
Macro calls, uses of SUBSTs, uses of CURRY-BEFORE and CURRY-AFTER,
and uses of functions for which OPEN-CODE-P is true, are all expanded.
Uses of some Common Lisp special forms will be expanded; use LISP:MACROEXPAND-1
to avoid this.
The second value is T if there was something to expand.
If SYS:RECORD-MACROS-EXPANDED is non-NIL, all macro names are pushed
on SYS:MACROS-EXPANDED.
The value of *MACROEXPAND-HOOK* (which should behave like FUNCALL)
is used to invoke the expander function."
  (declare (values expansion expanded-flag))
  ;; ||| Expand substs only during native compilation. -- smh 28sep88
  (expand-macro-call macro-call environment t))

;;; Expand any macros in top level of a form.

))

; From modified file DJ: L.SYS; QFCTNS.LISP#856 at 29-Sep-88 16:36:16
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFCTNS  "


(defun cl:macroexpand-1 (macro-call &optional environment)
  "Expand MACRO-CALL once and return the result.
Macro calls, uses of SUBSTs, uses of CURRY-BEFORE and CURRY-AFTER,
and uses of functions for which OPEN-CODE-P is true, are all expanded.
Common Lisp special forms are not expanded even if they are implemented
as macros; use ZL:MACROEXPAND-1 to get the expansion in terms of Zetalisp.
The second value is T if there was something to expand.
If SYS:RECORD-MACROS-EXPANDED is non-NIL, all macro names are pushed
on SYS:MACROS-EXPANDED.
The value of *MACROEXPAND-HOOK* (which should behave like FUNCALL)
is used to invoke the expander function."
  (declare (values expansion expanded-flag))
  ;; ||| Expand substs only during native compilation. -- smh 28sep88
  (expand-macro-call macro-call environment t
		     :inhibitor #'common-lisp-special-form-p
		     :macro-function-finder #'macro-function))

))

; From modified file DJ: L.SYS; QFCTNS.LISP#856 at 29-Sep-88 16:36:19
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFCTNS  "


(defmacro compiler::inherit-lambda-macro-definitions (&rest function-specs)
  (dolist (func function-specs)
    (setf (gethash func (compiler:compilation-environment-macro-hashtab compiler:*compilation-environment*))
	  :inherit-lambda-macro-definition))
  'nil)

))

; From modified file DJ: L.SYS; QFCTNS.LISP#856 at 29-Sep-88 16:36:20
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFCTNS  "


(DEFUN DECLARED-DEFINITION (FUNCTION-SPEC &AUX DEF (out-of-this-world nil) (allow-out-of-this-world nil))
  "Return the definition of FUNCTION-SPEC for macro expansion purposes.
This may be the actual definition, or it may be specified by
a local declaration.  If it is encapsulated, unencapsulate it."
  (SETQ DEF (OR (DOLIST (L LOCAL-DECLARATIONS)
		  (AND (EQ (CAR L) 'DEF)
		       (EQUAL (CADR L) FUNCTION-SPEC)		;Not EQ, might be a list
		       (RETURN (CDDR L))))
		(when (boundp 'compiler:*compilation-environment*)
		  (do ((env compiler:*compilation-environment* (compiler:compilation-environment-next env))
		       tem)
		      ((null env))
		    (when (setq tem (gethash function-spec (compiler:compilation-environment-macro-hashtab env)))
		      (if (eq tem :inherit-lambda-macro-definition)
			  (setq allow-out-of-this-world 't)
			(return tem)))))
		#+never
		(DOLIST (L FILE-LOCAL-DECLARATIONS)
		  (AND (EQ (CAR L) 'DEF)
		       (EQUAL (CADR L) FUNCTION-SPEC)		;Not EQ, might be a list
		       (RETURN (CDDR L))))
		;; If we wanted to keep the Falcon cross compiler from seeing Lambda macro definitions we should
		;; conditionalize out the following form.  While this would unquestionably be the right thing
		;; to do, in practice it would make the porting job much much more tedious. - smh 26sep88
		(let ((from-this-world (AND (FDEFINEDP FUNCTION-SPEC)
					    (SETQ DEF (FDEFINITION FUNCTION-SPEC))
					    (COND ((ATOM DEF) DEF)
						  ((EQ (CAR DEF) 'MACRO) DEF)
						  (T (FDEFINITION (UNENCAPSULATE-FUNCTION-SPEC FUNCTION-SPEC)))))))
		  (and from-this-world
		       (not allow-out-of-this-world)
		       (not (eq compiler:*host-computer* compiler:*target-computer*))
		       (setq out-of-this-world 't))
		  from-this-world)))
  (COND ((AND DEF (SYMBOLP DEF))
	 (multiple-value-bind (def out-of-that-world)
	     (DECLARED-DEFINITION DEF)
	   (values def (or out-of-this-world out-of-that-world))))
	(T (values DEF out-of-this-world))))

))