;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*- ;;; Private patches made by marc ;;; Written 28-Sep-88 14:24:40 by marc (Marc P. Rinfret) at site Silicart ;;; while running on Achernar from band 4 ;;; with System 125.19, ZWEI 125.3, ZMail 73.0, Local-File 75.0, File-Server 24.0, Unix-Interface 13.0, Tape 24.1, Lambda-Diag 17.0, microcode 1762, SDU Boot Tape 3.14, SDU ROM 8, 4.0cnf880928. ; From file A: RELEASE-4.NETWORK.CHAOS; QFILE.LISP#385 at 28-Sep-88 14:24:54 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; CHAOS; QFILE  " (DEFUN PROPERTIES-CHAOS (ACCESS TYPE THING ERROR-P &AUX (PATHNAME (CASE TYPE (:FILE THING) (:STREAM (SEND THING :TRUENAME)))) SETTABLE-PROPERTIES GOT-ERROR PLIST) "TYPE is either :FILE or :STREAM." (DECLARE (VALUES PLIST SETTABLE-PROPERTIES)) (WITH-OPEN-STREAM-CASE (S (MAKE-FILE-PROPERTY-LIST-STREAM-CHAOS ACCESS "PROPERTIES" "Properties" (IF (EQ TYPE :FILE) (FILE-PRINT-PATHNAME THING) "") (IF (EQ TYPE :STREAM) (SEND THING :FILE-HANDLE) "") PATHNAME ())) (ERROR (IF (NOT ERROR-P) (SETQ GOT-ERROR S) (SIGNAL-CONDITION S))) (:NO-ERROR (SETQ SETTABLE-PROPERTIES (FS:PARSE-SETTABLE-PROPERTIES (SEND S :LINE-IN) 0)) ;;;> (SETQ PLIST (SEND :ACCESS :READ-DIRECTORY-STREAM-ENTRY S PATHNAME)))) ;;;>>>>>>>>>>>>>>>>>>>> ?! (SETQ PLIST (SEND ACCESS :READ-DIRECTORY-STREAM-ENTRY S PATHNAME)))) ;;;... (OR GOT-ERROR (VALUES PLIST SETTABLE-PROPERTIES))) )) ; From file A: RELEASE-4.NETWORK.CHAOS; QFILE.LISP#385 at 28-Sep-88 14:25:27 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; CHAOS; QFILE  " (DEFUN MAKE-FILE-PROPERTY-LIST-STREAM-CHAOS (ACCESS COMMAND WHOSTATE STRING-ARG TOKEN-ARGS PATHNAME NO-ERROR-P &AUX DATA-CONN HOST-UNIT PKT SUCCESS NOT-ABORTED STRING (DEFAULT-CONS-AREA SYS:BACKGROUND-CONS-AREA)) (MULTIPLE-VALUE (DATA-CONN HOST-UNIT) (SEND ACCESS :GET-DATA-CONNECTION :INPUT)) (UNWIND-PROTECT (PROGN (MULTIPLE-VALUE-SETQ (PKT SUCCESS STRING) (SEND HOST-UNIT :COMMAND NIL (DATA-INPUT-HANDLE DATA-CONN) NIL WHOSTATE ;;;> COMMAND COMMAND #/SPACE ;;;... TOKEN-ARGS #/NEWLINE STRING-ARG #/NEWLINE)) (COND ((NOT SUCCESS) (SETQ NOT-ABORTED T) (SETQ STRING (STRING-APPEND STRING)) (SETF (DATA-STREAM DATA-CONN :INPUT) NIL) (QFILE-PROCESS-ERROR-NEW STRING PATHNAME NIL NO-ERROR-P :DIRECTORY-STREAM)) (T (QFILE-CHECK-COMMAND COMMAND STRING) (PROG1 (MAKE-INSTANCE 'QFILE-DIRECTORY-STREAM :HOST-UNIT HOST-UNIT :DATA-CONNECTION DATA-CONN :PATHNAME PATHNAME) (SETQ NOT-ABORTED T))))) (AND PKT (CHAOS:RETURN-PKT PKT)) ;; Both success and failure set NOT-ABORTED once they get past critical section. (UNLESS (OR NOT-ABORTED (NULL DATA-CONN) (NULL (SEND HOST-UNIT :CONTROL-CONNECTION))) ;; Here if aborted out of it and server may have directory stream open. (CONDITION-CASE () (MULTIPLE-VALUE-BIND (pkt CLOSE-SUCCESS) (SEND HOST-UNIT :COMMAND NIL (DATA-INPUT-HANDLE DATA-CONN) NIL "Close" "CLOSE") (and pkt (chaos:return-pkt pkt)) (WHEN CLOSE-SUCCESS (READ-UNTIL-SYNCHRONOUS-MARK (DATA-CONNECTION DATA-CONN))) (SEND HOST-UNIT :FREE-DATA-CONNECTION DATA-CONN :INPUT)) (SYS:HOST-STOPPED-RESPONDING NIL))))) )) ; From file A: RELEASE-4.IO.FILE; OPEN.LISP#210 at 28-Sep-88 14:28:45 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: IO; FILE; OPEN  " (DEFUN EXTRACT-ATTRIBUTE-LIST (STREAM &AUX WO PLIST PATH MODE ERROR) "Return the attribute list read from STREAM. STREAM can be reading either a text file or a QFASL file." (declare (values plist error)) (SETQ WO (SEND STREAM ':WHICH-OPERATIONS)) (COND ((MEMQ ':SYNTAX-PLIST WO) (SETQ PLIST (SEND STREAM ':SYNTAX-PLIST))) ;;;> SI:QFASL-STREAM-PROPERTY-LIST barf if stream is not a QFASL ;;;> Not being a character file does NOT imply being a QFASL ((send stream :send-if-handles :qfaslp) (setq plist (si:qfasl-stream-property-list stream))) ((NOT (SEND STREAM ':CHARACTERS)) ;;;> (SETQ PLIST (SI:QFASL-STREAM-PROPERTY-LIST STREAM))) nil) ; Can't do any better in this case ;;;... ;; If the file supports :READ-INPUT-BUFFER, check for absence of a plist ;; without risk that :LINE-IN will read the whole file ;; if the file contains no Return characters. ((AND (MEMQ ':READ-INPUT-BUFFER WO) (MULTIPLE-VALUE-BIND (BUFFER START END) (SEND STREAM ':READ-INPUT-BUFFER) (AND BUFFER (NOT (STRING-SEARCH "-*-" BUFFER START END))))) NIL) ;; If stream does not support :SET-POINTER, there is no hope ;; of parsing a plist, so give up on it. ((NOT (MEMQ ':SET-POINTER WO)) NIL) (T (DO ((LINE) (EOF)) (NIL) (MULTIPLE-VALUE (LINE EOF) (SEND STREAM ':LINE-IN NIL)) (COND ((NULL LINE) (SEND STREAM ':SET-POINTER 0) (RETURN NIL)) ((STRING-SEARCH "-*-" LINE) (SETQ LINE (FILE-GRAB-WHOLE-PROPERTY-LIST LINE STREAM)) (SEND STREAM ':SET-POINTER 0) (SETF (VALUES PLIST ERROR) (FILE-PARSE-PROPERTY-LIST LINE)) (RETURN NIL)) ((OR EOF (STRING-SEARCH-NOT-SET '(#/SPACE #/TAB) LINE)) (SEND STREAM ':SET-POINTER 0) (RETURN NIL)))))) ;; ;;From here on, infer properties where possible. ;; ;;Infer: Iff no MODE, try to get from pathname type (AND (NOT (GETF PLIST ':MODE)) (MEMQ ':PATHNAME WO) (SETQ PATH (SEND STREAM ':PATHNAME)) (SETQ MODE (CDR (ASSOC (SEND PATH ':TYPE) *FILE-TYPE-MODE-ALIST*))) (PUTPROP (LOCF PLIST) MODE ':MODE)) ;;Infer: Iff MODE or SYNTAX is CommonLISP or equivalent, set READTABLE ;; (this assumes ZL is still "traditional" and default!) (when (and (null (getf plist :readtable)) (or (member (getf plist :mode) '(:commonlisp :common-lisp)) (eq (getf plist :syntax) :CL))) (putprop (locf plist) :CL :readtable)) ;; ;;Finally return PLIST and any error from along the way. ;; (VALUES PLIST ERROR)) )) ; From file A: RELEASE-4.NETWORK.CHAOS; QFILE.LISP#385 at 28-Sep-88 14:33:39 #8R FILE-SYSTEM#: (COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM"))) (COMPILER::PATCH-SOURCE-FILE "SYS: NETWORK; CHAOS; QFILE  " (DEFUN READ-FILE-PROPERTY-LIST-STRING (STRING OPERATION PATHNAME &OPTIONAL (PROPERTIES-TO-READ ;properties are in order as expected in reply from file-computer. ; T is a special kludge to group time and date into one field for :CREATION-DATE. ; it turns out not to be really general enuf, see other part of kludge in :LENGTH below. '((:CREATION-DATE) (:CREATION-TIME) (:LENGTH T) (:QFASLP T) (:CHARACTERS T) (:AUTHOR T) (:byte-size t))) &AUX PATHNAME-ORIGIN PROPERTY-LIST (DEFAULT-CONS-AREA SYS:BACKGROUND-CONS-AREA)) (OR (SETQ PATHNAME-ORIGIN (STRING-SEARCH-CHAR #/NEWLINE STRING)) (FERROR NIL "Illegally formatted string ~S." STRING)) (DO ((I (QFILE-CHECK-COMMAND OPERATION STRING)) (PROP PROPERTIES-TO-READ (CDR PROP)) (*READ-BASE* 10.) (*READTABLE* SI:INITIAL-READTABLE) (TYPE) (DATE-START)) ((OR (NULL I) (> I PATHNAME-ORIGIN) (NULL PROP))) (SETQ TYPE (CAAR PROP)) (CASE TYPE (:CREATION-DATE (SETQ DATE-START I)) (:LENGTH (PUSH (OR (FS:PARSE-DIRECTORY-DATE-PROPERTY STRING DATE-START I) ;; When bootstrapping, dates are recorded as strings. (SUBSTRING STRING DATE-START I)) PROPERTY-LIST) (PUSH :CREATION-DATE PROPERTY-LIST))) (COND ((CADAR PROP) ;;;> It was impossible to open a file when the current package was a package not USEing GLOBAL ;;;> It would intern a NIL in the current package that wouldn't be EQ GLOBAL:NIL... which ;;;> would screw up properties with the value NIL (which obviously would not be NULL)...!!! (let ((*package* (find-package 'user))) ; any pre-existing package using global should do (MULTIPLE-VALUE-BIND (PROPVAL ENDPOS) (CL:READ-FROM-STRING STRING NIL NIL :START I :end pathname-origin) (SETQ I ENDPOS) (PUSH PROPVAL PROPERTY-LIST) (PUSH TYPE PROPERTY-LIST))) ) ;;;... (T (SETQ I (STRING-SEARCH-CHAR #/SPACE STRING (1+ I)))))) (PUSH (SEND PATHNAME :PARSE-TRUENAME (SUBSTRING STRING (SETQ PATHNAME-ORIGIN (1+ PATHNAME-ORIGIN)) (STRING-SEARCH-CHAR #/NEWLINE STRING PATHNAME-ORIGIN))) PROPERTY-LIST) (PUSH :TRUENAME PROPERTY-LIST) PROPERTY-LIST) ))