;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Patch file for System version 124.34
;;; Reason:
;;;  Further support for CommonLISP mode file attribute for reader, loader, etc.
;;;  Given 'Mode:CommonLISP' or 'Mode:Common-LISP', FS:FILE-EXTRACT-ATTRIBUTE-LIST
;;;  now infers 'Readtable:CL'.  Same for 'SYNTAX:CL'.  Note that we don't override
;;;  any attribute that is actually listed on the mode line.
;;;  
;;;  If any system code depends on 'Mode:LISP', a file with 'Mode:CommonLISP' will 
;;;  be a problem, but I haven't found any such cases.  The readtable really matters
;;;  for successful compilation, loading, etc.
;;; Written 7-Jun-88 18:06:19 by keith (Keith M. Corbett) at site Gigamos Cambridge
;;; while running on Breaking Glass from band 3
;;; with Experimental System 124.31, Experimental Local-File 74.1, Experimental File-Server 23.1, Experimental Unix-Interface 12.0, Experimental ZMail 72.0, Experimental Tape 23.6, Experimental Lambda-Diag 16.1, microcode 1756, SDU Boot Tape 3.14, SDU ROM 103.



; From modified file DJ: L.IO.FILE; OPEN.LISP#207 at 7-Jun-88 18:06:20
#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)))
	((NOT (SEND STREAM ':CHARACTERS))
	 (SETQ PLIST (SI:QFASL-STREAM-PROPERTY-LIST STREAM)))
	;; 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))

))