;;; -*- Mode:Lisp; Readtable:ZL; Package:USER; Base:8; Patch-File:T -*-
;;; Private patches made by jim
;;; Reason:
;;;  Allow logical pathanames like k:a.a.b;f.lisp
;;;  (.'s just like ;'s)
;;; Written 5-May-88 18:30:11 by jim (Jim O'Dell) at site Gigamos Cambridge
;;; while running on Maurice Ravel from band 1
;;; with Experimental System 123.254, Experimental Local-File 73.5, Experimental FILE-Server 22.4, Experimental Unix-Interface 11.0, Experimental KERMIT 34.3, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, Experimental Tape 22.4, microcode 1755, SDU Boot Tape 3.14, SDU ROM 102, the old ones.



; From modified file DJ: L.IO.FILE; PATHST.LISP#214 at 5-May-88 18:30:37
#8R FILE-SYSTEM#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "FILE-SYSTEM")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: IO; FILE; PATHST  "

(DEFMETHOD (LOGICAL-PATHNAME :PARSE-NAMESTRING) (IGNORE NAMESTRING &OPTIONAL (START 0) END
						 &aux semicolon-p found-semicolon)
  (OR END (SETQ END (STRING-LENGTH NAMESTRING)))
  (setq semicolon-p (string-search #/; namestring start end))
  (DO ((I START)
       (J START (1+ J))
       CH TEM Q
       DIR NAM NAMP TYP TYPP VERS)
      ((> J END)
       (SETQ DIR (NREVERSE DIR))
       (VALUES :UNSPECIFIC DIR NAM TYP VERS))
    (SETQ CH (IF (= J END) #/SP (AREF NAMESTRING J)))
    (COND ((= CH '#/)
	   (SETQ J (1+ J)))
	  ((MEMQ CH '(#/; #/: #/ #/ #/SP #/TAB #/. #/#))
	   (COND ((OR ( I J) (= CH #/) (= CH #/))
		  (AND (MEM #'= CH '(#/ #/))
		       (OR ( I J)
			   (AND ( (1+ J) END)
				( (AREF NAMESTRING (1+ J)) #/SP)))
		       (PATHNAME-ERROR (1+ J) NAMESTRING
				       "An unquoted ~C must be a component unto itself." CH))
		  (MULTIPLE-VALUE (TEM Q)
		    (SELECTQ CH
		      (#/ (VALUES :UNSPECIFIC NIL))
		      (#/ (VALUES NIL NIL))
		      (T (UNQUOTE-LOGICAL-STRING NAMESTRING I J))))
		  (IF (AND (NOT Q) (STRING= TEM "*"))
		      (SETQ TEM :WILD))
		  (cond ((eq ch #/:) nil)
			((or (eq #/; ch)
			     (and (eq #/. ch)
				  semicolon-p
				  (not found-semicolon)))
			 (if (eq ch #/;)
			     (setq found-semicolon t))
			 (push tem dir))
			('OTHERWISE
			 (COND (VERS)
			       (TYPP (SETQ VERS (COND ((MEMQ TEM '(:UNSPECIFIC :WILD)) TEM)
						      ((AND (NOT Q)
							    (COND ((STRING= TEM ">") :NEWEST)
								  ((STRING= TEM "<") :OLDEST)
								  ((NUMERIC-P TEM)))))
						      (T (PATHNAME-ERROR J NAMESTRING
									 "Version not numeric")))))
			       (NAMP (SETQ TYP TEM TYPP T))
			       (T (SETQ NAM TEM NAMP T)))))))
	   (SETQ I (1+ J))))))

))