;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 125.4
;;; Reason:
;;;  Improved logic and error messages for trying to compile a flavor
;;;  instance that can't be reconstructed in a load file.  (If the flavor
;;;  doesn't handle one of the methods :FASD-FORM or :RECONSTRUCT-INIT-PLIST,
;;;  the compiler can't compile an instance.)
;;;  
;;;  Also, provide :FASD-FORM method for SI:HOST flavor.  This means you can
;;;  now compile constant references to hosts, e.g.
;;;  
;;;  	 (setq x #FS:UNIX-HOST "ANGEL")
;;;  
;;;  This is hardly ever what you really want to do, but at least it works.
;;; Written 11-Jul-88 20:25:06 by keith (Keith Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 3
;;; with System 125.3, ZWEI 125.0, ZMail 73.0, Local-File 75.0, File-Server 24.0, Unix-Interface 13.0, Tape 24.0, Lambda-Diag 17.0, microcode 1761, SDU Boot Tape 3.14, SDU ROM 103.



; From modified file DJ: L.SYS; QCFASD.LISP#260 at 11-Jul-88 20:25:07
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCFASD  "

(DEFUN FASD-CONSTANT (S-EXP &OPTIONAL (LIST-OP FASL-OP-LIST))
  (BLOCK NIL
    (AND FASD-NEW-SYMBOL-FUNCTION			;For FASD-SYMBOLS-PROPERTIES,
	 (SYMBOLP S-EXP)				;make sure we examine all symbols in
	 (FUNCALL FASD-NEW-SYMBOL-FUNCTION S-EXP))	;the data that we dump.
    (LET ((TEM  (FASD-TABLE-LOOKUP S-EXP)))		;Check if this object already dumped
      (WHEN TEM						;Yup.
	(COND (( TEM (LSH 1 16.))
	       (FASD-START-GROUP NIL 2 FASL-OP-LARGE-INDEX)
	       (FASD-NIBBLE (LDB (byte 8. 16.) TEM))
	       (FASD-NIBBLE (LDB (byte 16. 0) TEM)))
	      (T
	       (FASD-START-GROUP NIL 1 FASL-OP-INDEX)	;Just reference it in the FASL TABLE.
	       (FASD-NIBBLE TEM)))
	    (RETURN TEM)))
    (TYPECASE S-EXP
      (INTEGER (FASD-FIXED S-EXP))
      (CHARACTER (FASD-CHARACTER S-EXP))
      (SHORT-FLOAT (FASD-SHORT-FLOAT S-EXP))
      (SINGLE-FLOAT (FASD-SINGLE-FLOAT S-EXP))
      (SYMBOL (FASD-SYMBOL S-EXP))
      (STRING (RETURN (FASD-STRING S-EXP)))
      (ARRAY (RETURN (FASD-ARRAY S-EXP)))
      (COMPILED-FUNCTION (FASD-FEF S-EXP))
      (CONS (RETURN (FASD-LIST S-EXP LIST-OP)))
      (INSTANCE (FASD-EVAL-CONSTRUCT-CONSTANT
		  (OR (SEND S-EXP ':SEND-IF-HANDLES ':FASD-FORM)
		      (and (send s-exp :get-handler-for :reconstruction-init-plist)
			   `(APPLY 'MAKE-INSTANCE
				   '(,(TYPE-OF S-EXP)
				     . ,(SEND S-EXP ':RECONSTRUCTION-INIT-PLIST))))
		      (ferror "The instance ~S cannot be compiled.~
~&It is an instance of a type which does not provide a way to make a fast-load representation."
			      s-exp))))
      (RATIO (RETURN (FASD-RATIONAL S-EXP)))
      (COMPLEX (RETURN (FASD-COMPLEX S-EXP)))
      (T (FERROR "The constant ~S cannot be compiled.~
~&The data-type ~S is not suitable for compiling as a fast-load constant (FASD-CONSTANT)."
		 S-EXP (TYPE-OF S-EXP))))
    (FASD-TABLE-ADD S-EXP)))

))

; From modified file DJ: L.NETWORK; HOST.LISP#158 at 11-Jul-88 20:25:34
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; HOST  "

(defmethod (host :fasd-form) ()
  ;;;A method for giving the compiler a form that when eval'd will reconstruct SELF.
  `(prog(host hostname oldtype)
	(setq oldtype ',(type-of self))
	(setq hostname ,(send self :name))
	(setq host (si:parse-host hostname))
	(unless (typep host oldtype)
	  (warn "When host ~a was compiled, it's type was ~s, but now it is type ~s"
		hostname oldtype (type-of host)))
	(return host)))

))