[Mit-cadr-cvs] r343 - trunk/lisp/patch

[ggilley at common-lisp.net]

Author: ggilley
Date: Fri Nov 23 09:09:30 2012
New Revision: 343

Log:
changed case of filename

Added:
   trunk/lisp/patch/system-78-1.lisp

Added: trunk/lisp/patch/system-78-1.lisp
==============================================================================
--- /dev/null	00:00:00 1970	(empty, because file is newly added)
+++ trunk/lisp/patch/system-78-1.lisp	Fri Nov 23 09:09:30 2012	(r343)
@@ -0,0 +1,147 @@
+;;; -*- Mode: Lisp; Package: User; Base: 8.; Patch-File: T -*-
+;;; Patch file for System version 78.1
+;;; Reason: Fix band transfer server
+;;; Written 12/07/81 21:39:32 by MMcM,
+;;; while running on Lisp Machine Seven from band 7
+;;; with Experimental System 78.0, Experimental ZMail 38.0, microcode 836.
+
+
+
+; From file ZMACS 296 ZWEI; AI:
+#8R ZWEI:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "ZWEI")))
+
+(DEFUN SAVE-BUFFER (BUFFER &AUX FILE-ID PATHNAME)
+  (SETQ FILE-ID (BUFFER-FILE-ID BUFFER)  
+	PATHNAME (BUFFER-PATHNAME BUFFER))
+  (COND ((NULL FILE-ID)
+	 (FS:SET-DEFAULT-PATHNAME (FUNCALL (DEFAULT-PATHNAME) ':NEW-NAME (BUFFER-NAME BUFFER))
+				  *PATHNAME-DEFAULTS*)
+	 (SETQ PATHNAME (IF *WINDOW* (READ-DEFAULTED-PATHNAME "Save File:" (PATHNAME-DEFAULTS)
+							      NIL NIL ':WRITE)
+			  (FORMAT QUERY-IO "~&Save file to: ")
+			  (MAKE-DEFAULTED-PATHNAME (READLINE) (PATHNAME-DEFAULTS))))
+	 (SET-BUFFER-PATHNAME PATHNAME BUFFER)))
+  (AND (OR (SYMBOLP FILE-ID)
+	   (EQUAL FILE-ID (WITH-OPEN-FILE (S PATHNAME '(:PROBE :ASCII))
+			    (AND (NOT (STRINGP S)) (FUNCALL S ':INFO))))
+	   (FQUERY '#,`(:SELECT T
+			:BEEP T
+		        :TYPE READLINE
+		        :CHOICES ,FORMAT:YES-OR-NO-P-CHOICES)
+		   "~A has been changed on disk since you last read or wrote it.~@
+		    Save it anyway? "
+		   PATHNAME))
+       (WRITE-FILE-INTERNAL PATHNAME BUFFER))
+  T)
+
+)
+
+; From file ZMACS 296 ZWEI; AI:
+#8R ZWEI:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "ZWEI")))
+
+;;; This can be called from top-level to try to save a bombed ZMACS
+(DEFUN SAVE-ALL-FILES ()
+  (DOLIST (BUFFER *ZMACS-BUFFER-LIST*)
+    (AND (LET ((BUFFER-TICK (BUFFER-TICK BUFFER)))
+	   (AND (NUMBERP BUFFER-TICK)
+		(> (NODE-TICK BUFFER) BUFFER-TICK)))
+	 (FQUERY NIL "Save file ~A ? " (BUFFER-NAME BUFFER))
+	 (LET ((*WINDOW* NIL)
+	       (*WINDOW-LIST* NIL)
+	       (*INTERVAL* NIL)
+	       (*TYPEOUT-WINDOW* STANDARD-OUTPUT)
+	       (*TYPEIN-WINDOW* STANDARD-OUTPUT)
+	       (*NUMERIC-ARG-P* NIL))
+	   (SAVE-BUFFER BUFFER)))))
+
+)
+
+; From file SALVAG > ZWEI; AI:
+#8R CADR:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "CADR")))
+
+;;;-*- Mode:LISP; Package:CADR -*-
+
+;;; Save all files on the object machine
+(DEFUN SALVAGE-EDITOR ()
+  (PKG-GOTO "CADR")				;Lots of stuff doesn't work otherwise
+  (DO ((BUFFER-LIST (CC-MEM-READ (1+ (QF-POINTER (QF-SYMBOL 'ZWEI:*ZMACS-BUFFER-LIST*))))
+		    (QF-CDR BUFFER-LIST))
+       BUFFER)
+      ((CC-Q-NULL BUFFER-LIST))
+    (SETQ BUFFER (QF-CAR BUFFER-LIST))
+    (AND (LET ((BUFFER-TICK (QF-AR-1 BUFFER (GET-DEFSTRUCT-INDEX 'ZWEI:BUFFER-TICK 'AREF))))
+	   (AND (= DTP-FIX (LOGLDB %%Q-DATA-TYPE BUFFER-TICK))
+		(> (LOGLDB %%Q-POINTER
+			   (QF-AR-1 BUFFER (GET-DEFSTRUCT-INDEX 'ZWEI:NODE-TICK 'AREF)))
+		   (LOGLDB %%Q-POINTER BUFFER-TICK))))
+	 (LET ((BUFFER-NAME (WITH-OUTPUT-TO-STRING (CC-OUTPUT-STREAM)
+			      (CC-Q-PRINT-STRING
+				(QF-AR-1 BUFFER
+					 (GET-DEFSTRUCT-INDEX 'ZWEI:BUFFER-NAME 'AREF))))))
+	   (AND (FQUERY NIL "Save buffer ~A? " BUFFER-NAME)
+		(SALVAGE-INTERVAL BUFFER
+				  (IF (NOT (CC-Q-NULL
+					     (QF-AR-1 BUFFER
+						      (GET-DEFSTRUCT-INDEX
+							'ZWEI:BUFFER-FILE-ID 'AREF))))
+				      BUFFER-NAME
+				    (FORMAT QUERY-IO "~&Write ~A to file: " BUFFER-NAME)
+				    (READLINE QUERY-IO))))))))
+
+)
+
+; From file DISK > LMIO; AI:
+#8R SYSTEM-INTERNALS:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "SYSTEM-INTERNALS")))
+
+;Returns NIL if no such partition, or 3 values (FIRST-BLOCK N-BLOCKS LABEL-LOC) if it exists
+(DEFUN FIND-DISK-PARTITION (NAME &OPTIONAL RQB (UNIT 0) (ALREADY-READ-P NIL) CONFIRM-WRITE
+			    &AUX (RETURN-RQB NIL))
+  (DECLARE (RETURN-LIST FIRST-BLOCK N-BLOCKS LABEL-LOC NAME))
+  (IF (AND (CLOSUREP UNIT)
+	   (FUNCALL UNIT ':HANDLES-LABEL))
+      (FUNCALL UNIT ':FIND-DISK-PARTITION NAME)
+      (PROG FIND-DISK-PARTITION ()
+	(UNWIND-PROTECT
+	  (PROGN
+	    (COND ((NULL RQB)
+		   (WITHOUT-INTERRUPTS
+		     (SETQ RETURN-RQB T
+			   RQB (GET-DISK-RQB)))))
+	    (OR ALREADY-READ-P (READ-DISK-LABEL RQB UNIT))
+	    (DO ((N-PARTITIONS (GET-DISK-FIXNUM RQB 200))
+		 (WORDS-PER-PART (GET-DISK-FIXNUM RQB 201))
+		 (I 0 (1+ I))
+		 (LOC 202 (+ LOC WORDS-PER-PART)))
+		((= I N-PARTITIONS) NIL)
+	      (COND ((STRING-EQUAL (GET-DISK-STRING RQB LOC 4) NAME)
+		     (AND CONFIRM-WRITE
+			  (NOT (FQUERY FORMAT:YES-OR-NO-QUIETLY-P-OPTIONS
+				"Do you really want to clobber partition ~A ~
+				 ~:[~*~;on unit ~D ~](~A)? "
+				NAME (NUMBERP UNIT) UNIT				
+				(GET-DISK-STRING RQB (+ LOC 3) 16.)))
+			  (RETURN-FROM FIND-DISK-PARTITION NIL T))
+		     (RETURN-FROM FIND-DISK-PARTITION
+				  (GET-DISK-FIXNUM RQB (+ LOC 1))
+				  (GET-DISK-FIXNUM RQB (+ LOC 2))
+				  LOC
+				  NAME)))))
+	  (AND RETURN-RQB (RETURN-DISK-RQB RQB))))))
+
+)
+
+; From file EHR > LMWIN; AI:
+#8R EH:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "EH")))
+
+(DEFUN ERRORP (THING)
+  (STRINGP THING))
+
+)
+
+; From file GLOBAL > LISPM2; AI:
+#8R EH:(COMPILER-LET ((PACKAGE (PKG-FIND-PACKAGE "EH")))
+
+(GLOBALIZE 'ERRORP)
+
+)
+