;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Patch file for System version 124.78 ;;; Reason: ;;; (open "file" :direction :probe) to a non-Lisp machine using QFILE constructed ;;; a bogus open message. (open "file" :direction nil) worked fine. ;;; Written 18-Jun-88 17:44:18 by pld (Peter L. DeWolf) at site Gigamos Cambridge ;;; while running on Brahms' First from band 1 ;;; with Experimental System 124.74, Experimental Local-File 74.2, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.0, Experimental Tape 23.6, Experimental Lambda-Diag 16.2, microcode 1761, SDU Boot Tape 3.14, SDU ROM 103, the old ones. ; From modified file DJ: L.NETWORK.CHAOS; QFILE.LISP#382 at 18-Jun-88 17:45:02 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; CHAOS; QFILE  " (DEFUN QFILE-IF-DOES-NOT-EXIST-STRING (DIRECTION IF-DOES-NOT-EXIST IF-EXISTS-P) (IF (OR IF-EXISTS-P (NEQ IF-DOES-NOT-EXIST (CASE DIRECTION ((:INPUT NIL :PROBE-DIRECTORY :PROBE-LINK) :ERROR) (:probe nil) (:OUTPUT :CREATE)))) (STRING-APPEND " IF-DOES-NOT-EXIST " (IF (EQ IF-DOES-NOT-EXIST NIL) "ERROR" IF-DOES-NOT-EXIST)) "")) )) ; From modified file DJ: L.NETWORK.CHAOS; QFILE.LISP#382 at 18-Jun-88 17:45:03 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; CHAOS; QFILE  " (DEFUN QFILE-OPEN-DIRECTION-STRING (DIRECTION) ;; should get protocol-violation error of some form (ECASE DIRECTION ((:probe NIL) "PROBE") (:PROBE-DIRECTORY "PROBE-DIRECTORY") (:PROBE-LINK "PROBE INHIBIT-LINKS") (:INPUT "READ") (:OUTPUT "WRITE"))) )) ; From modified file DJ: L.NETWORK.CHAOS; QFILE.LISP#382 at 18-Jun-88 17:45:06 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; CHAOS; QFILE  " (DEFUN OPEN-CHAOS (ACCESS FILE PATHNAME &REST OPTIONS &KEY (DIRECTION :INPUT) (CHARACTERS T) (ERROR T) (ELEMENT-TYPE 'STRING-CHAR ELEMENT-TYPE-P) (IF-EXISTS nil if-exists-p) (IF-DOES-NOT-EXIST nil if-does-not-exist-p) (BYTE-SIZE :DEFAULT) MOBY-MAPPED &ALLOW-OTHER-KEYS &AUX HOST-UNIT DATA-CONN PKT NOT-ABORTED PHONY-CHARACTERS SIGN-EXTEND-BYTES (DEFAULT-CONS-AREA SYS:BACKGROUND-CONS-AREA)) (SETQ PATHNAME (FS:PARSE-PATHNAME PATHNAME)) (IF IF-EXISTS-P (CHECK-TYPE IF-EXISTS (MEMBER :ERROR :NEW-VERSION :RENAME :RENAME-AND-DELETE :OVERWRITE :APPEND :TRUNCATE :SUPERSEDE NIL)) (SETQ IF-EXISTS (IF (MEMQ (PATHNAME-VERSION PATHNAME) ;; :UNSPECIFIC here is to prevent lossage ;; writing ITS files with no version numbers. '(:NEWEST :UNSPECIFIC)) :NEW-VERSION :ERROR))) (IF IF-DOES-NOT-EXIST-P (CHECK-TYPE IF-DOES-NOT-EXIST (MEMBER :ERROR :CREATE NIL)) (SETQ IF-DOES-NOT-EXIST (COND ((MEMQ DIRECTION '(:PROBE :PROBE-LINK :PROBE-DIRECTORY)) NIL) ((AND (EQ DIRECTION :OUTPUT) (NOT (MEMQ IF-EXISTS '(:OVERWRITE :TRUNCATE :APPEND)))) :CREATE) ;; Note: if DIRECTION is NIL, this defaults to :ERROR ;; for compatibility with the past. ;; A Common-Lisp program would use :PROBE ;; and get NIL as the default for this. (T :ERROR)))) (ECASE DIRECTION ((:INPUT :OUTPUT :PROBE-DIRECTORY :PROBE-LINK)) (:IO (FERROR "Bidirectional file streams are not yet supported.")) ((NIL :PROBE))) ;; IF-EXISTS-P is T if we need to give the IF-EXISTS to the server. (SETQ IF-EXISTS-P (NOT (MEMQ IF-EXISTS (CASE (PATHNAME-VERSION PATHNAME) (:NEWEST '(:NEW-VERSION)) (:UNSPECIFIC '(:NEW-VERSION :SUPERSEDE)))))) (WHEN ELEMENT-TYPE-P (SETF (VALUES CHARACTERS BYTE-SIZE PHONY-CHARACTERS SIGN-EXTEND-BYTES) (DECODE-ELEMENT-TYPE ELEMENT-TYPE BYTE-SIZE))) (flet ((make-stream (string) (LET ((PROPERTIES (READ-FILE-PROPERTY-LIST-STRING STRING "OPEN" PATHNAME))) (AND (EQ CHARACTERS :DEFAULT) (SETQ CHARACTERS (GETF PROPERTIES :CHARACTERS))) (UNLESS (OR (EQ BYTE-SIZE :DEFAULT) (GETF PROPERTIES :BYTE-SIZE)) (SETF (GETF PROPERTIES :BYTE-SIZE) BYTE-SIZE)) (PROG1 (cond (moby-mapped (open-chaos-moby-mapped host-unit properties string)) ;defined in moby stuff. (t (MAKE-INSTANCE (CASE DIRECTION (:INPUT (IF CHARACTERS 'QFILE-INPUT-CHARACTER-STREAM (COND (SIGN-EXTEND-BYTES 'QFILE-INPUT-SIGNED-BINARY-STREAM) (PHONY-CHARACTERS 'QFILE-INPUT-PHONY-CHARACTER-STREAM) (T 'QFILE-INPUT-BINARY-STREAM)))) (:OUTPUT (IF CHARACTERS 'QFILE-OUTPUT-CHARACTER-STREAM (IF PHONY-CHARACTERS 'QFILE-OUTPUT-PHONY-CHARACTER-STREAM 'QFILE-OUTPUT-BINARY-STREAM))) (T 'QFILE-PROBE-STREAM)) :HOST-UNIT HOST-UNIT :DATA-CONNECTION DATA-CONN :PROPERTY-LIST PROPERTIES :PATHNAME PATHNAME))) (SETQ NOT-ABORTED T)))) (data-connection-handle () (CASE DIRECTION (:INPUT (DATA-INPUT-HANDLE DATA-CONN)) (:OUTPUT (DATA-OUTPUT-HANDLE DATA-CONN))))) (HANDLING-FILE-ERRORS (ERROR) (PROGN (IF (or moby-mapped (MEMQ DIRECTION '(NIL :probe :PROBE-DIRECTORY :PROBE-LINK))) ;; PROBE mode implies no need for data connection (SETQ HOST-UNIT (SEND ACCESS :GET-HOST-UNIT)) (MULTIPLE-VALUE (DATA-CONN HOST-UNIT) (SEND ACCESS :GET-DATA-CONNECTION DIRECTION))) (UNWIND-PROTECT (let ((success nil) (string nil)) (MULTIPLE-VALUE (PKT SUCCESS STRING) (lexpr-send access :open-command host-unit (data-connection-handle) file characters byte-size direction if-exists if-exists-p if-does-not-exist options)) (SETQ STRING (STRING-APPEND STRING)) (AND PKT (CHAOS:RETURN-PKT PKT)) (COND ((NOT SUCCESS) (SETQ NOT-ABORTED T) (OR (NULL DATA-CONN) (SETF (DATA-STREAM DATA-CONN DIRECTION) NIL)) (CONDITION-CASE-IF (NOT IF-DOES-NOT-EXIST) () (CONDITION-CASE-IF (NOT IF-EXISTS) () (QFILE-PROCESS-ERROR-NEW STRING PATHNAME NIL (NOT ERROR) :OPEN) (FILE-ALREADY-EXISTS NIL)) (FILE-NOT-FOUND NIL))) (T (make-stream string)))) ;; cleanup forms of the unwind-protect (UNLESS (OR NOT-ABORTED (NULL DATA-CONN) (NULL (SEND HOST-UNIT :CONTROL-CONNECTION))) ;; Here if aborted out of it and server may have file open. (CONDITION-CASE () (PROGN (when (EQ DIRECTION :OUTPUT) (let ((pkt (SEND HOST-UNIT :COMMAND NIL (DATA-OUTPUT-HANDLE DATA-CONN) NIL "Delete" "DELETE"))) (and pkt (chaos:return-pkt pkt)))) (multiple-value-bind (pkt success ignore) (SEND HOST-UNIT :COMMAND NIL (data-connection-handle) NIL "Close" "CLOSE") (and pkt (chaos:return-pkt pkt)) (WHEN success (CASE DIRECTION (:INPUT (READ-UNTIL-SYNCHRONOUS-MARK (DATA-CONNECTION DATA-CONN))) (:OUTPUT (CHAOS:SEND-PKT (DATA-CONNECTION DATA-CONN) (CHAOS:GET-PKT) %QFILE-SYNCHRONOUS-MARK-OPCODE))))) (SEND HOST-UNIT :FREE-DATA-CONNECTION DATA-CONN DIRECTION)) (SYS:HOST-STOPPED-RESPONDING NIL)))))))) ))