;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 121.1
;;; Reason:
;;;  * Changes from Release 3:
;;;   218:
;;;    Describing a symbol uses better criteria for figuring out when
;;;     it is interned in other packages.
;;;    MACROLET'ed macros are now seen by local functions.
;;;   210:
;;;    OK, so LISP:TIME is a macro.  Sue me.
;;;   222:
;;;    Fix COMPILER::FIX-SYNONYM-SPECIAL-FORM, which wasn't rewriting forms
;;;     using special forms aliased to other special forms correctly.
;;;     The most common lossage occured when advising a function after binding
;;;     ZL:COMPILE-ENCAPSULATIONS-FLAG non-NIL.
;;;   237:
;;;    Fix redisplayer of RH buffer to call :STRING-OUT with the
;;;     END argument supplied, avoiding possible bombouts due to
;;;     STRING-LENGTH.
;;;  SI::SET-DOCUMENTATION doesn't add an entry on the alist if the
;;;   documentation is null.
;;; Written 29-Dec-86 15:53:24 by rg at site LMI Cambridge
;;; while running on Curley from band 2
;;; with Experimental System 121.0, Experimental Lambda-Diag 15.0, Experimental ZMail 70.0, Experimental KERMIT 32.0, Experimental Unix-Interface 10.0, Experimental Local-File 72.0, Experimental FILE-Server 21.0, Experimental Tape 13.0, Experimental IMicro 19.0, microcode 1729, SDU Boot Tape 3.14, SDU ROM 103.



; From modified file DJ: L.WINDOW; RH.LISP#178 at 29-Dec-86 15:53:26
#8R TV#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "TV")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: WINDOW; RH  "

(DEFUN-RH RH-REPRINT-INPUT (&OPTIONAL CHAR DONT-SET-PROMPT-CURSORPOS)
  "Reprint the contents of the rubout handler buffer at the current cursor position."
  (if (characterp char) (setq char (char-int char)))
  (UNLESS DONT-SET-PROMPT-CURSORPOS
    (multiple-value-setq (PROMPT-STARTING-X PROMPT-STARTING-Y)
      (SEND SELF :READ-CURSORPOS)))
  (LET ((PROMPT (OR (ASSQ ':REPROMPT RUBOUT-HANDLER-OPTIONS)
		    (ASSQ ':PROMPT RUBOUT-HANDLER-OPTIONS))))
    (IF PROMPT (RUBOUT-HANDLER-PROMPT (CADR PROMPT) SELF CHAR)))
  (MULTIPLE-VALUE-SETQ (RUBOUT-HANDLER-STARTING-X RUBOUT-HANDLER-STARTING-Y)
    (SEND SELF :READ-CURSORPOS))
  (LET ((MORE-PROCESSING-GLOBAL-ENABLE NIL))
    (SEND SELF :STRING-OUT RUBOUT-HANDLER-BUFFER 0 (length rubout-handler-buffer)))
  (RH-CURSOR-MOTION (RH-TYPEIN-POINTER))
  NIL)

))

; From modified file DJ: L.SYS; QRAND.LISP#492 at 29-Dec-86 15:55:52
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QRAND  "

(defun cli:make-array (dimensions &rest options
		       &key element-type initial-element initial-contents
		       adjustable fill-pointer displaced-to displaced-index-offset)
  (declare (arglist dimensions &key element-type initial-element initial-contents
		    adjustable fill-pointer displaced-to displaced-index-offset)
	   ;; Just using &KEY for checking.
	   (ignore element-type initial-element initial-contents
		   adjustable fill-pointer displaced-index-offset)
	   (values array))
  ;; Don't allow fixnums for displaced location.
  (check-type displaced-to (or null array))
  ;; ZL:MAKE-ARRAY returns three values.
  (values (apply #'zl:make-array dimensions options)))

))

; From modified file DJ: L.SYS; QRAND.LISP#492 at 29-Dec-86 15:56:18
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QRAND  "


(defmacro cli:time (form)
  "Evaluate FORM in the current lexical environment, returning the values it returns,
while printing to *TRACE-OUTPUT* a message saying how long it took."
  (let ((xtime (gensym)) (otime (gensym)) (ntime (gensym)) (values (gensym)))
    `(let ((,xtime (time:microsecond-time))
	   (,otime (time:microsecond-time))
	   (,values (multiple-value-list ,form))
	   (,ntime (time:microsecond-time)))
       (format *trace-output*
	       "~&Evaluation of ~S took ~:D microseconds."
	       ',form (- (+ ,ntime ,xtime) ,otime ,otime))
       (values-list ,values))))

(defun time (&optional form)
  "Time in 60'ths of a second.  Only differences between values are significant.
Time values wrap around about once a day, so use TIME-LESSP, TIME-INCREMENT
and TIME-DIFFERENCE to compare and compute times.

If FORM is specified, we evaluate it, return the values it returns,
while printing to *TRACE-OUTPUT* a message saying how long it took."
  (if form
      (eval `(cli:time ,form)) ;; Blech, but I don't really care
    (time-in-60ths)))

))

; From modified file DJ: L.SYS; QRAND.LISP#492 at 29-Dec-86 15:57:55
#8R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; QRAND  "

(DEFUN SET-DOCUMENTATION (SYMBOL DOC-TYPE VALUE)
  (LET* ((S (SYMBOL-NAME DOC-TYPE))
	 (C (ASSOC-EQUAL S (GET SYMBOL 'DOCUMENTATION-PROPERTY))))
    (IF C
	(SETF (CDR C) VALUE)
      (when value ;; don't make an entry if it's null
	(LET ((DEFAULT-CONS-AREA (IF (= (%AREA-NUMBER SYMBOL) NR-SYM)
				     PROPERTY-LIST-AREA
				   BACKGROUND-CONS-AREA)))
	  (PUSH (CONS S VALUE) (GET SYMBOL 'DOCUMENTATION-PROPERTY))))))
  VALUE)

))

; From modified file DJ: L.SYS; QCOPT.LISP#172 at 29-Dec-86 15:58:31
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCOPT  "

(defun fix-synonym-special-form (form)
  (cons (let ((original (si::interpreter-special-form (car form))))
	  (if (null original) ;; not really a special form ??  Well...
	      (function-name (symbol-function (car form)))
	    (si::interpreter-special-form-name original)))
	(cdr form)))

))

; From modified file DJ: L.SYS; QCP1.LISP#674 at 29-Dec-86 16:00:30
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCP1  "

(defun (:property lambda p1) (form)
  (breakoff form *function-environment*))

))

; From modified file DJ: L.SYS; QCP1.LISP#674 at 29-Dec-86 16:01:10
#8R COMPILER#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "COMPILER")))
  (PATCH-SOURCE-FILE "SYS: SYS; QCP1  "

(DEFUN P1FUNCTION (FORM &AUX (FUNCTION (CADR FORM)))
  (COND ((SYMBOLP FUNCTION)
	 (LET ((TM (ASSQ FUNCTION *LOCAL-FUNCTIONS*)))
	   (IF TM				;Ref to a local fn made by FLET or LABELS:
	       (TRY-REF-LEXICAL-HOME		;Really ref the local var that holds it.
		 (CADR TM)
		 `(FUNCTION ,function))
	     FORM)))				;Global function definition.
	;;>> Should barf about macros and special forms!
	((FUNCTIONP FUNCTION T)		;Functional constant
	 (SETQ FUNCTION (LAMBDA-MACRO-EXPAND FUNCTION))
	 (IF (MEMQ (CAR-SAFE FUNCTION) '(LAMBDA NAMED-LAMBDA))
	     (BREAKOFF FUNCTION *function-environment*)
	   `',FUNCTION))
	((AND (CONSP FUNCTION)			;Function spec
	      (VALIDATE-FUNCTION-SPEC FUNCTION))
	 FORM)
	(T
	 (WARN 'BAD-ARGUMENT :IMPOSSIBLE
	       "The argument of ~S is ~S, neither a function nor the name of one."
	       'FUNCTION (CADR FORM))
	 ''NIL)))

))

; From modified file DJ: L.SYS; DESCRIBE.LISP#21 at 29-Dec-86 16:01:55
#10R SYSTEM-INTERNALS#: #!:CL
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; DESCRIBE  "

(defun describe-symbol (sym)
  (let ((symbol-package (symbol-package sym)))
    (format t "~%Symbol ~S is in ~:[no~;the ~:*~A~] package." sym (symbol-package sym))
    (let ((tem nil))
      (dolist (p *all-packages*)
	(unless (eq p symbol-package)
	  (multiple-value-bind (s flag) (find-symbol sym p)
	    (when (and flag
		       (eq s sym) ;; are we talking about the same symbol ?
		       (not (eq flag :inherited)))
	      (push p tem)))))
      (when tem (format t "~% It is ~:[strangely~;also~] interned in package~P ~{~A~^, ~}"
			symbol-package (length tem) tem))))
  (when (and (boundp sym) (not (keywordp sym)))
    (let ((*print-level* *describe-print-level*)
	  (*print-length* *describe-print-length*))
      (format t "~%The value of ~S is ~S" sym (symbol-value sym)))
    (describe-1 (symbol-value sym)))
  (when (fboundp sym)
    (let ((*print-level* *describe-print-level*)
	  (*print-length* *describe-print-length*))
      (ignore-errors
	(format t "~%The function definition of ~S is ~S: ~S"
		sym (symbol-function sym) (arglist sym))))
	 (describe-1 (symbol-function sym)))
  (do ((pl (symbol-plist sym) (cddr pl))
       (*print-level* *describe-print-level*)
       (*print-length* *describe-print-length*))
      ((null pl))
    (format t "~%~S has property ~S: ~S"
	    sym (car pl) (cadr pl))
    (describe-1 (cadr pl)))
  (if (not (or (boundp sym) (fboundp sym) (symbol-plist sym)))
      (format t "~%It has no value, definition or properties"))
  nil)

))