;;; -*- Mode:Lisp; Readtable:CL; Package:USER; Base:10; Patch-File:T -*-
;;; Patch file for System version 123.260
;;; Reason:
;;;  (common-lisp t t) now truly does affect new Lisp Listeners and Zwei Buffers
;;;  that don't have a :readtable attribute.
;;; Written 6-May-88 20:39:17 by pld at site Gigamos Cambridge
;;; while running on Fish food from band 3
;;; with Experimental System 123.259, Experimental Local-File 73.5, Experimental FILE-Server 22.4, Experimental Unix-Interface 11.0, Experimental KERMIT 34.3, Experimental ZMail 71.2, Experimental Lambda-Diag 15.0, Experimental Tape 22.4, microcode 1756, SDU Boot Tape 3.14, SDU ROM 103.



; From modified file DJ: L.SYS; REP.LISP#21 at 6-May-88 20:39:24
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; REP  "

(DEFUN LISP-TOP-LEVEL1 (*TERMINAL-IO* &OPTIONAL (TOP-LEVEL-P T) &AUX OLD-PACKAGE W-PKG)
  "Read-eval-print loop used by lisp listeners.
*TERMINAL-IO* is the stream with which to read and print."
  (LET-IF (VARIABLE-BOUNDP *PACKAGE*) ((*PACKAGE* *PACKAGE*))
    (WHEN (FBOUNDP 'FORMAT)
      (FORMAT T "~&;Reading~:[~; at top level~]~@[ in ~A~]."
	      TOP-LEVEL-P (SEND-IF-HANDLES *TERMINAL-IO* :NAME)))
    (PUSH NIL *VALUES*)
    (DO ((*READTABLE* (SYMBOL-VALUE-GLOBALLY '*READTABLE*))
	 (LAST-TIME-READTABLE NIL)
	 THROW-FLAG)	;Gets non-NIL if throw to COMMAND-LEVEL (e.g. quitting from an error)
	(NIL)		;Do forever
      ;; If *PACKAGE* has changed, set OLD-PACKAGE and tell our window.
      ;; Conversely, if the window's package has changed, change ours.
      ;; The first iteration, we always copy from the window.
      (COND ((NOT (VARIABLE-BOUNDP *PACKAGE*)))
	    ((EQ *TERMINAL-IO* COLD-LOAD-STREAM))
	    ;; User set the package during previous iteration of DO
	    ;; => tell the window about it.
	    ((AND OLD-PACKAGE (NEQ *PACKAGE* OLD-PACKAGE))
	     (SEND-IF-HANDLES *TERMINAL-IO* :SET-PACKAGE *PACKAGE*)
	     (SETQ OLD-PACKAGE *PACKAGE*))
	    ;; Window's package has been changed, or first iteration through DO,
	    ;; => set our package to the window's -- if the window has one.
	    ((SETQ W-PKG (SEND-IF-HANDLES *TERMINAL-IO* :PACKAGE))
	     (AND (NEQ W-PKG *PACKAGE*)
		  (SETQ *PACKAGE* W-PKG))
	     (SETQ OLD-PACKAGE *PACKAGE*))
	    ;; First time ever for this window => set window's package
	    ;; to the global value of *PACKAGE*.
	    ((NULL OLD-PACKAGE)
	     (SETQ OLD-PACKAGE *PACKAGE*)
	     (SEND-IF-HANDLES *TERMINAL-IO* :SET-PACKAGE *PACKAGE*)))
      (CHECK-FOR-READTABLE-CHANGE LAST-TIME-READTABLE)
      (SETQ LAST-TIME-READTABLE *READTABLE*)
      (SETQ THROW-FLAG T)
      (CATCH-ERROR-RESTART ((SYS:ABORT DBG:DEBUGGER-CONDITION) "Return to top level in ~A."
			    (OR (SEND-IF-HANDLES *TERMINAL-IO* :NAME) "current process."))
	(TERPRI)
	(SETQ +++ ++ ++ + + -)			;Save last three input forms
	(SETQ - (READ-FOR-TOP-LEVEL))
	(LET ((LISP-TOP-LEVEL-INSIDE-EVAL T)
	      VALUES)
	  (UNWIND-PROTECT
	      (SETQ VALUES (MULTIPLE-VALUE-LIST (EVAL-ABORT-TRIVIAL-ERRORS -)))
	    ;; Always push SOMETHING -- NIL if evaluation is aborted.
	    (PUSH VALUES *VALUES*))
	  (SETQ /// //
		// /
		/ VALUES)
	  (SETQ *** **				;Save first value, propagate old saved values
		** *
		* (CAR /)))
	(DOLIST (VALUE /)
	  (TERPRI)
	  (FUNCALL (OR PRIN1 #'PRIN1) VALUE))
	(SETQ THROW-FLAG NIL))
      (WHEN THROW-FLAG
	;; Inform user of return to top level.
	(FORMAT T "~&;Back to top level~@[ in ~A~]."
		(SEND-IF-HANDLES *TERMINAL-IO* :NAME))))))

))

; From modified file DJ: L.SYS; REP.LISP#21 at 6-May-88 20:39:29
#10R SYSTEM-INTERNALS#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: SYS; REP  "


(defun common-lisp (flag &optional globally-p &aux (old-rdtbl *readtable*))
  "Makes the default syntax be either Common Lisp (if FLAG is non-NIL)
or Traditional Zetalisp (if FLAG is NIL)"
  (setq *readtable* (if flag common-lisp-readtable standard-readtable))
  (setq zwei:*default-readtable* *readtable*)
  (when globally-p
    (setq-globally *readtable* *readtable*)
    (setq-globally zwei:*default-readtable* *readtable*))
  (if (eq *readtable* old-rdtbl) flag (values)))

))