;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.93
;;; Reason:
;;;  Compiler and macroexpander changes for cross compilation.
;;;  During cross compilation SETF methods for the host machine are not seen.
;;;  COM-CROSS-COMPILE now sets up an affects *FALCON-ENVIRONMENT*.
;;;  New commands: COM-MACRO-EXPAND-[ALL-]CROSS-COMPILERLY.
;;; Written 28-Sep-88 15:49:46 by smh at site Gigamos Cambridge
;;; while running on Alex from band 3
;;; with Experimental System 126.92, Experimental ZWEI 126.13, Experimental ZMail 74.1, 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; QCFILE.LISP#380 at 28-Sep-88 15:50:36
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCFILE  "


(defun LOAD-FDEF-FILE (input-file &key (*compilation-environment* *falcon-environment*))
  (let* ((FILE (FS:MERGE-PATHNAME-DEFAULTS (OR INPUT-FILE "") *DEFAULT-PATHNAME-DEFAULTS*))
	 (pathname (send file :new-pathname :type :fdef :version :NEWEST)))
    (load pathname)))

;; Note: Some file servers just cant hack :IF-EXISTS :SUPERSEDE without first deleting the old
;;       QFASL. Therefore if compilation bombs you lose your old qfasl file forever.
;;       Also MAKE-SYSTEM looks at creation dates, not version numbers in any case.
;; -gjc

))

; From modified file DJ: L.SYS; QCFILE.LISP#380 at 28-Sep-88 15:50:40
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCFILE  "

(defun write-compilation-environment (compilation-environment pathname &aux pvals mvals)
  ;;(print-comp-env compilation-environment)
  (maphash #'(lambda (k v) (push (cons k v) pvals))
	   (compilation-environment-plist-hashtab compilation-environment))
  (maphash #'(lambda (k v) (push (cons k v) mvals))
	   (compilation-environment-macro-hashtab compilation-environment))
  ;; rebind target while writing FENV so it gets written for the right machine.  ||| 28sep88 smh
  (let ((*target-computer* 'lambda-interface))
    (zl:dump-forms-to-file
      (fs:merge-pathname-components pathname nil :default-type :FDEF)
      `((load-to-compilation-environment-internal
	  ',(compilation-environment-target compilation-environment)
	  ',pvals
	  ',mvals))
      `(:package ,(package-name *package*)
		 :readtable ,(car (si:rdtbl-names *readtable*))))))

))

; From modified file DJ: L.SYS; QCFILE.LISP#380 at 28-Sep-88 15:50:46
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCFILE  "

(defun load-to-compilation-environment-internal (target plists macros)
  (unless (compilation-environment-p *compilation-environment*)
    (error "Attempting to load a compilation-environment without binding *COMPILATION-ENVIRONMENT*
to a COMPILATION-ENVIRONMENT object."))
  (unless (equal (compilation-environment-target *compilation-environment*) target)
    (error "Attepting to load a compilation-environment for target ~S but *COMPILATION-ENVIRONMENT*
has a target of ~S." target (compilation-environment-target *compilation-environment*)))
  (let ((pht (compilation-environment-plist-hashtab *compilation-environment*)))
    (dolist (key-pvals plists)
      (let ((plist (gethash (car key-pvals) pht)))
	(do ((p (cdr key-pvals) (cddr p)))
	    ((null p))
	  (setf (getf plist (car p)) (cadr p)))
	(setf (gethash (car key-pvals) pht) plist))))
  (let ((mht (compilation-environment-macro-hashtab *compilation-environment*)))
    (dolist (key-macro macros)
      (setf (gethash (car key-macro) mht) (cdr key-macro)))))

;;;; Barf all over SPECIAL and UNSPECIAL "declarations."

;;; When not compiling a file, etc., or in Maclisp,
;;;  we simply put on or remove a SPECIAL property.
;;; When compiling a file (COMPILE-NO-LOAD-FLAG is T)
;;;  we just use FILE-LOCAL-DECLARATIONS to make the change.
;;; SPECIAL just pushes one big entry on FILE-LOCAL-DECLARATIONS, to save consing.
;;; UNSPECIAL, for each symbol, tries to avoid lossage in the case where a symbol
;;; is repeatedly made special and then unspecial again, by removing any existing
;;; unshadowed SPECIALs from FILE-LOCAL-DECLARATIONS, and then putting on an UNSPECIAL
;;; only if there isn't already one.  This way, FILE-LOCAL-DECLARATIONS doesn't keep growing.

;;; SPECIAL-1 and UNSPECIAL-1 can be used to make a computed symbol special or unspecial.

))

; From modified file DJ: L.SYS; QFCTNS.LISP#854 at 28-Sep-88 15:50:53
#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)))
      (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
		      (cond ((typep (setq tm (declared-definition name)) '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
					 (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)
			     (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
				   (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#854 at 28-Sep-88 15:50:58
#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 (memq (compiler:target-processor-symbol) *features*)))

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

))

; From modified file DJ: L.SYS; QFCTNS.LISP#854 at 28-Sep-88 15:51:00
#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 (memq (compiler:target-processor-symbol) *features*)
		     :inhibitor #'common-lisp-special-form-p
		     :macro-function-finder #'macro-function))

))

; From modified file DJ: L.SYS; QFCTNS.LISP#854 at 28-Sep-88 15:51:03
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QFCTNS  "

(DEFUN GETDECL (NAME PROP)
  "GET, for macro expansion and compilation.
Allows the actual property of NAME to be overridden
by a local declaration (prop name value)
such as PUTDECL or DEFDECL would create.
NAME may be any symbol or function spec."
  (DOLIST (DECL LOCAL-DECLARATIONS)
    (AND (EQ (CAR DECL) PROP)
	 (EQUAL (CADR DECL) NAME)
	 (RETURN-from getdecl (CADDR DECL))))
  (when (boundp 'compiler:*compilation-environment*)
    (do ((env compiler:*compilation-environment* (compiler:compilation-environment-next env)))
	((null env))
      (multiple-value-bind (val foundp)
	  (gethash name (compiler:compilation-environment-plist-hashtab env))
	(when foundp
	  (setq val (getf val prop))		;what about property of NIL ???
	  (when val (return-from getdecl val))))))
  #+never
  (DOLIST (DECL FILE-LOCAL-DECLARATIONS)
    (AND (EQ (CAR DECL) PROP)
	 (EQUAL (CADR DECL) NAME)
	 (RETURN (CADDR DECL))))
  ;; The AND clause added to keep the cross compiler from seeing inappropriate DEFTYPE and
  ;; SETF-METHOD definitions from the compiling host. ||| smh 28sep88
  (and (memq (compiler:target-processor-symbol) *features*)
       (IF (SYMBOLP NAME)
	   (GET NAME PROP)
	 (FUNCTION-SPEC-GET NAME PROP))))

))