;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 126.40
;;; Reason:
;;;  Add FASD-INDEX, and make FASL-OP-K-IMMEDIATES and FASD-K-LOAD-TIME-EVALS.
;;; Written 11-Aug-88 13:33:41 by wkf (William K. Foster) at site Gigamos Cambridge
;;; while running on Love from band 2
;;; with Experimental System 126.32, ZWEI 125.14, ZMail 73.2, Local-File 75.2, File-Server 24.1, Unix-Interface 13.0, Tape 24.2, Lambda-Diag 17.0, microcode 1762, SDU Boot Tape 3.13, SDU ROM 102, Kcold Loaded -- 8/3/88.



; From modified file DJ: L.SYS; QCFASD.LISP#263 at 11-Aug-88 13:33:41
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCFASD  "

(defun fasd-index (idx)
  (cond (( idx (lsh 1 16.))
	 (fasd-start-group nil 2 si:fasl-op-large-index)
	 (fasd-nibble (ldb (byte 8. 16.) idx))
	 (fasd-nibble (ldb (byte 16. 0) idx)))
	(t
	 (fasd-start-group nil 1 si::fasl-op-index)	;Just reference it in the FASL TABLE.
	 (fasd-nibble idx))))

))

; From modified file DJ: L.SYS; QCFASD.LISP#263 at 11-Aug-88 13:33:54
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCFASD  "

(DEFUN FASD-CONSTANT (S-EXP &OPTIONAL (LIST-OP SI::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 ((idx  (FASD-TABLE-LOOKUP S-EXP)))		;Check if this object already dumped
      (WHEN idx						;Yup.
	(fasd-index idx)
	(RETURN idx)))
    (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)))
      #+(target lambda)
      (COMPILED-FUNCTION (FASD-FEF S-EXP))
      #+(target falcon)
      (compiled-function
       ;; Close approximation; as close as could make any sense anyway, really,
       ;; except for anonymous compiled functions!
       (let ((name (function-name s-exp)))
	 (unless name
	   (ferror "We cannot yet dump anonymous compiled functions as constants on the Falcon."))
	 (fasd-k-compiled-function name)))
      (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.SYS; QCFASD.LISP#263 at 11-Aug-88 13:34:00
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCFASD  "

(defun fasd-k-immediates (function-index immediates)
  (let ((len (length immediates)))
  (fasd-start-group nil 0 si::fasl-op-k-immediates)
  (fasd-index function-index)
  (fasd-fixed (// len 2))
  (do ((i 0 (+ i 2)))
      ((>= i len))
    (fasd-fixed (svref immediates i))		;ref offset
    (fasd-constant (svref immediates (1+ i))))))	;immediate object

))

; From modified file DJ: L.SYS; QCFASD.LISP#263 at 11-Aug-88 13:34:04
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCFASD  "

(defun fasd-k-load-time-evals (function-index items)
  (let ((len (length items)))
  (fasd-start-group nil 0 si::fasl-op-k-load-time-evals)
  (fasd-index function-index)
  (fasd-fixed len)
  (loop for (offset form) in items
	do
	(fasd-fixed offset)  ;ref offset
	(fasd-constant form))))
))