Index: /trunk/ccl/level-1/l1-files.lisp
===================================================================
--- /trunk/ccl/level-1/l1-files.lisp	(revision 313)
+++ /trunk/ccl/level-1/l1-files.lisp	(revision 314)
@@ -181,604 +181,4 @@
 
 
-#|
-(defstruct (pattern
-	    (:constructor make-pattern (pieces)))
-  (pieces nil :type list))
-
-(defmethod make-load-form ((p pattern))
-  (make-load-form-saving-slots p))
-
-(defmethod print-object ((p pattern) stream)
-  (print-unreadable-object (p stream :type t)
-    (let* ((pieces (pattern-pieces p)))
-      (if *print-pretty*
-        (let ((*print-escape* t))
-	  (pprint-fill stream pieces nil))
-	(prin1 pieces stream)))))
-
-(defvar *ignore-wildcards* nil)
-
-
-(defun remove-backslashes (namestr start end)
-  "Remove and occurences of \\ from the string because we've already
-   checked for whatever they may have been backslashed."
-  (declare (type simple-base-string namestr)
-	   (type index start end))
-  (let* ((result (make-string (- end start) :element-type 'base-char))
-	 (dst 0)
-	 (quoted nil))
-    (do ((src start (1+ src)))
-	((= src end))
-      (cond (quoted
-	     (setf (schar result dst) (schar namestr src))
-	     (setf quoted nil)
-	     (incf dst))
-	    (t
-	     (let ((char (schar namestr src)))
-	       (cond ((char= char #\\)
-		      (setq quoted t))
-		     (t
-		      (setf (schar result dst) char)
-		      (incf dst)))))))
-    (when quoted
-      (error 'namestring-parse-error
-	     :complaint "Backslash in bad place."
-	     :namestring namestr
-	     :offset (1- end)))
-    (shrink-vector result dst)))
-
-(defun maybe-make-pattern (namestr start end)
-  (declare (type simple-base-string namestr)
-	   (type index start end))
-  (if *ignore-wildcards*
-      (subseq namestr start end)
-      (let* ((pattern ()))
-	(let* ((quoted nil)
-	      (any-quotes nil)
-	      (last-regular-char nil)
-	      (index start))
-	  (flet ((flush-pending-regulars ()
-		   (when last-regular-char
-		     (push (if any-quotes
-			       (remove-backslashes namestr
-						   last-regular-char
-						   index)
-			       (subseq namestr last-regular-char index)) 
-			   pattern)
-		     (setf any-quotes nil)
-		     (setf last-regular-char nil))))
-	    (loop
-	      (when (>= index end)
-		(return))
-	      (let ((char (schar namestr index)))
-		(cond (quoted
-		       (incf index)
-		       (setf quoted nil))
-		      ((char= char #\\)
-		       (setf quoted t)
-		       (setf any-quotes t)
-		       (unless last-regular-char
-			 (setf last-regular-char index))
-		       (incf index))
-		      ((char= char #\?)
-		       (flush-pending-regulars)
-		       (push :single-char-wild pattern)
-		       (incf index))
-		      ((char= char #\*)
-		       (flush-pending-regulars)
-		       (push :multi-char-wild pattern)
-		       (incf index))
-		      ((char= char #\[)
-		       (flush-pending-regulars)
-		       (let ((close-bracket
-			      (position #\] namestr :start index :end end)))
-			 (unless close-bracket
-			   (error 'namestring-parse-error
-				  :complaint "``['' with no corresponding ``]''"
-				  :namestring namestr
-				  :offset index))
-			 (push (list :character-set
-					(subseq namestr
-						(1+ index)
-						close-bracket))
-			  pattern)
-			 (setf index (1+ close-bracket))))
-		      (t
-		       (unless last-regular-char
-			 (setf last-regular-char index))
-		       (incf index)))))
-	    (flush-pending-regulars)))
-	(cond ((null (setq pattern (nreverse pattern)))
-	       "")
-	      ((null (cdr pattern))
-	       (let ((piece (first pattern)))
-		 (typecase piece
-		   ((member :multi-char-wild) :wild)
-		   (simple-string piece)
-		   (t
-		    (make-pattern pattern)))))
-	      (t
-	       (make-pattern pattern))))))
-
-(defun extract-name-type-and-version (namestr start end)
-  (declare (type simple-base-string namestr)
-	   (type index start end))
-  (let* ((last-dot (position #\. namestr :start (1+ start) :end end
-			     :from-end t))
-	 (second-to-last-dot (and last-dot
-				  (position #\. namestr :start (1+ start)
-					    :end last-dot :from-end t)))
-	 (version nil))
-    ;; If there is a second-to-last dot, check to see if there is a valid
-    ;; version after the last dot.
-    (when second-to-last-dot
-      (cond ((and (= (+ last-dot 2) end)
-		  (char= (schar namestr (1+ last-dot)) #\*))
-	     (setf version :wild))
-	    ((and (< (1+ last-dot) end)
-		  (do ((index (1+ last-dot) (1+ index)))
-		      ((= index end) t)
-		    (unless (char<= #\0 (schar namestr index) #\9)
-		      (return nil))))
-	     (setf version
-		   (parse-integer namestr :start (1+ last-dot) :end end)))
-	    (t
-	     (setf second-to-last-dot nil))))
-    (cond (second-to-last-dot
-	   (values (maybe-make-pattern namestr start second-to-last-dot)
-		   (maybe-make-pattern namestr
-				       (1+ second-to-last-dot)
-				       last-dot)
-		   version))
-	  (last-dot
-	   (values (maybe-make-pattern namestr start last-dot)
-		   (maybe-make-pattern namestr (1+ last-dot) end)
-		   version))
-	  (t
-	   (values (maybe-make-pattern namestr start end)
-		   nil
-		   version)))))
-
-;;; Take a string and return a list of cons cells that mark the char
-;;; separated subseq. The first value t if absolute directories location.
-;;;
-(defun split-at-slashes (namestr start end)
-  (declare (type simple-base-string namestr)
-	   (type index start end))
-  (let ((absolute (and (/= start end)
-		       (char= (schar namestr start) #\/))))
-    (when absolute
-      (incf start))
-    ;; Next, split the remainder into slash seperated chunks.
-    (let* ((pieces ()))
-      (loop
-	(let ((slash (position #\/ namestr :start start :end end)))
-	  (push (cons start (or slash end)) pieces)
-	  (unless slash
-	    (return))
-	  (setf start (1+ slash))))
-      (values absolute (nreverse pieces)))))
-
-(defun parse-unix-namestring (namestr start end)
-  (declare (type simple-base-string namestr)
-	   (type index start end))
-  (multiple-value-bind
-      (absolute pieces)
-      (split-at-slashes namestr start end)
-    (multiple-value-bind
-	  (name type)
-	(let* ((tail (car (last pieces)))
-	       (tail-start (car tail))
-	       (tail-end (cdr tail)))
-	  (unless (= tail-start tail-end)
-	    (setf pieces (butlast pieces))
-	    (extract-name-type-and-version namestr tail-start tail-end)))
-      ;; Now we have everything we want.  So return it.
-      (values nil ; no host for unix namestrings.
-	      (let* ((dirs ()))
-		(dolist (piece pieces)
-		  (let* ((piece-start (car piece))
-			 (piece-end (cdr piece)))
-		    (unless (= piece-start piece-end)
-		      (cond ((string= namestr ".." :start1 piece-start
-				      :end1 piece-end)
-			     (push :up dirs))
-			    ((string= namestr "**" :start1 piece-start
-				      :end1 piece-end)
-			     (push :wild-inferiors dirs))
-			    (t
-			     (push (maybe-make-pattern namestr
-						       piece-start
-						       piece-end) 
-			      dirs))))))
-		(setq dirs (nreverse dirs))
-		(cond (absolute
-		       (cons :absolute dirs))
-		      (dirs
-		       (cons :relative dirs))
-		      (t
-		       nil)))
-	      name
-	      type
-	      nil))))
-
-(defun unparse-unix-piece (thing)
-  (etypecase thing
-    ((member :wild) "*")
-    (simple-string
-     (let* ((srclen (length thing))
-	    (dstlen srclen))
-       (dotimes (i srclen)
-	 (case (schar thing i)
-	   ((#\* #\? #\[)
-	    (incf dstlen))))
-       (let ((result (make-string dstlen :element-type 'base-char))
-	     (dst 0))
-	 (dotimes (src srclen)
-	   (let ((char (schar thing src)))
-	     (case char
-	       ((#\* #\? #\[)
-		(setf (schar result dst) #\\)
-		(incf dst)))
-	     (setf (schar result dst) char)
-	     (incf dst)))
-	 result)))
-    (pattern
-     (let* ((strings ()))
-       (dolist (piece (pattern-pieces thing))
-	 (etypecase piece
-	   (simple-string
-	    (push piece strings))
-	   (symbol
-	    (ecase piece
-	      (:multi-char-wild
-	       (push "*" strings))
-	      (:single-char-wild
-	       (push "?" strings))))
-	   (cons
-	    (case (car piece)
-	      (:character-set
-	       (push "[" strings)
-	       (push (cdr piece) strings)
-	       (push "]" strings))
-	      (t
-	       (error "Invalid pattern piece: ~S" piece))))))
-       (apply #'concatenate
-	      'simple-string
-	      (nreverse strings))))))
-
-(defun unparse-unix-directory-list (directory)
-  (declare (type list directory))
-  (let* ((pieces ()))
-    (when directory
-      (ecase (pop directory)
-	(:absolute
-	 (push "/" pieces))
-	(:relative
-	 ;; Nothing special.
-	 ))
-      (dolist (dir directory)
-	(typecase dir
-	  ((member :up)
-	   (push "../" pieces))
-	  ((member :back)
-	   (error ":BACK cannot be represented in namestrings."))
-	  ((member :wild-inferiors)
-	   (push "**/" pieces))
-	  ((or simple-string pattern)
-	   (push (unparse-unix-piece dir) pieces)
-	   (push "/" pieces))
-	  (t
-	   (error "Invalid directory component: ~S" dir)))))
-    (apply #'concatenate 'simple-string (nreverse pieces))))
-
-(defun %pathname-host (pathname)
-  (if (logical-pathname-p pathname)
-      (%logical-pathname-host pathname)
-      :unspecific))
-
-(defun %pathname-version (pathname)
-  (if (logical-pathname-p pathname)
-      (%logical-pathname-version pathname)
-      :newest))
-
-(defun unparse-unix-file (pathname)
-  (declare (type pathname pathname))
-  (let* ((strings ()))
-    (let* ((name (%pathname-name pathname))
-	   (type (%pathname-type pathname))
-	   (type-supplied (not (or (null type) (eq type :unspecific))))
-	   (version (%pathname-version pathname))
-	   (version-supplied (not (or (null version) (eq version :newest)))))
-      (when name
-	(push (unparse-unix-piece name) strings))
-      (when type-supplied
-	(push "." strings)
-	(push (unparse-unix-piece type) strings))
-      (when version-supplied
-	(unless type-supplied
-	  (error "Cannot specify the version without a type: ~S" pathname))
-	(push (if (eq version :wild)
-	     ".*"
-	     (format nil ".~D" version)) 
-	 strings)))
-    (apply #'concatenate 'simple-string (nreverse strings))))
-
-(defun unparse-unix-namestring (pathname)
-  (declare (type pathname pathname))
-  (concatenate 'simple-string
-	       (unparse-unix-directory-list (%pathname-directory pathname))
-	       (unparse-unix-file pathname)))
-
-(defun unparse-logical-piece (thing)
-  (etypecase thing
-    (simple-string thing)
-    (pattern
-     (let* ((strings ()))
-       (dolist (piece (pattern-pieces thing))
-	 (etypecase piece
-	   (simple-string (push piece strings))
-	   (keyword
-	    (cond ((eq piece :wild-inferiors)
-		   (push "**" strings))
-		  ((eq piece :multi-char-wild)
-		   (push "*" strings))
-		  (t (error "Invalid keyword: ~S" piece))))))
-       (apply #'concatenate 'simple-string (nreverse strings))))))
-
-(defun unparse-logical-directory (pathname)
-  (declare (type pathname pathname))
-  (let* ((pieces ()))
-    (let ((directory (%pathname-directory pathname)))
-      (when directory
-	(ecase (pop directory)
-	  (:absolute)	 ;; Nothing special.
-	  (:relative (push ";" pieces)))
-	(dolist (dir directory)
-	  (cond ((or (stringp dir) (pattern-p dir))
-		 (push (unparse-logical-piece dir) pieces)
-		 (push ";" pieces))
-		((eq dir :wild)
-		 (push "*;" pieces))
-		((eq dir :wild-inferiors)
-		 (push "**;" pieces))
-		(t
-		 (error "Invalid directory component: ~S" dir))))))
-    (apply #'concatenate 'simple-string (nreverse pieces))))
-
-(defun unparse-logical-namestring (pathname)
-  (declare (type logical-pathname pathname))
-  (concatenate 'simple-string
-	       (%pathname-host pathname) ":"
-	       (unparse-logical-directory pathname)
-	       (unparse-unix-file pathname)))
-
-(defun maybe-make-logical-pattern (namestring chunks)
-  (let* ((chunk (caar chunks)))
-    (let* ((pattern ()))
-      (let* ((last-pos 0)
-	     (len (length chunk)))
-	(declare (fixnum last-pos))
-	(loop
-	  (when (= last-pos len) (return))
-	  (let ((pos (or (position #\* chunk :start last-pos) len)))
-	    (if (= pos last-pos)
-		(when pattern
-		  (error 'namestring-parse-error
-			 :complaint "Double asterisk inside of logical ~
-				     word: ~S"
-			 :arguments (list chunk)
-			 :namestring namestring
-			 :offset (+ (cdar chunks) pos)))
-		(push (subseq chunk last-pos pos) pattern))
-	    (if (= pos len)
-		(return)
-		(push :multi-char-wild pattern))
-	    (setq last-pos (1+ pos)))))
-      (setq pattern (nreverse pattern))
-	(if (cdr pattern)
-	    (make-pattern pattern)
-	    (let ((x (car pattern)))
-	      (if (eq x :multi-char-wild)
-		  :wild
-		  x))))))
-
-(defun logical-chunkify (namestr start end)
-  (let* ((chunks nil))
-    (do ((i start (1+ i))
-	 (prev 0))
-	((= i end)
-	 (when (> end prev)
-	    (push (cons (subseq namestr prev end) prev) chunks)))
-      (let ((ch (schar namestr i)))
-	(unless (or (alpha-char-p ch) (digit-char-p ch)
-		    (member ch '(#\- #\*)))
-	  (when (> i prev)
-	    (push (cons (subseq namestr prev i) prev) chunks))
-	  (setq prev (1+ i))
-	  (unless (member ch '(#\; #\: #\.))
-	    (error 'namestring-parse-error
-		   :complaint "Illegal character for logical pathname:~%  ~S"
-		   :arguments (list ch)
-		   :namestring namestr
-		   :offset i))
-	  (push (cons ch i) chunks))))
-    (nreverse chunks)))
-
-(defun find-logical-host (hostname &optional (errorp t))
-  (let* ((found (%str-assoc hostname %logical-host-translations%)))
-    (unless (or found (not errorp))
-      (error "Logical host not yet defined: ~S" hostname))
-    (car found)))
-
-(defun parse-logical-namestring (namestr start end)
-  (declare (type simple-base-string namestr)
-	   (type index start end))
-  (let* ((directory ()))
-    (let* ((host nil)
-	   (name nil)
-	   (type nil)
-	   (version nil))
-      (labels ((expecting (what chunks)
-		 (unless (and chunks (simple-string-p (caar chunks)))
-		   (error 'namestring-parse-error
-			  :complaint "Expecting ~A, got ~:[nothing~;~S~] ."
-			  :arguments (list what (caar chunks) (caar chunks))
-			  :namestring namestr
-			  :offset (if chunks (cdar chunks) end)))
-		 (caar chunks))
-	       (parse-host (chunks)
-		 (case (caadr chunks)
-		   (#\:
-		    (setq host
-			  (find-logical-host (expecting "a host name" chunks)))
-		    (parse-relative (cddr chunks)))
-		   (t
-		    (parse-relative chunks))))
-	       (parse-relative (chunks)
-		 (case (caar chunks)
-		   (#\;
-		    (push :relative directory)
-		    (parse-directory (cdr chunks)))
-		   (t
-		    (push :absolute directory) ; Assumption! Maybe revoked later.
-		    (parse-directory chunks))))
-	       (parse-directory (chunks)
-		 (case (caadr chunks)
-		   (#\;
-		    (push
-		     (let ((res (expecting "a directory name" chunks)))
-		       (cond ((string= res "..") :up)
-			     ((string= res "**") :wild-inferiors)
-			     (t
-			      (maybe-make-logical-pattern namestr chunks))))
-		     directory)
-		    (parse-directory (cddr chunks)))
-		   (t
-		    (parse-name chunks))))
-	       (parse-name (chunks)
-		 (when chunks
-		   (expecting "a file name" chunks)
-		   (setq name (maybe-make-logical-pattern namestr chunks))
-		   (expecting-dot (cdr chunks))))
-	       (expecting-dot (chunks)
-		 (when chunks
-		   (unless (eql (caar chunks) #\.)
-		     (error 'namestring-parse-error
-			    :complaint "Expecting a dot, got ~S."
-			    :arguments (list (caar chunks))
-			    :namestring namestr
-			    :offset (cdar chunks)))
-		   (if type
-		     (parse-version (cdr chunks))
-		     (parse-type (cdr chunks)))))
-	       (parse-type (chunks)
-		 (expecting "a file type" chunks)
-		 (setq type (maybe-make-logical-pattern namestr chunks))
-		 (expecting-dot (cdr chunks)))
-	       (parse-version (chunks)
-		 (let ((str (expecting "a positive integer, * or NEWEST"
-				       chunks)))
-		   (cond
-		     ((string= str "*") (setq version :wild))
-		     ((string= str "NEWEST") (setq version :newest))
-		     (t
-		      (multiple-value-bind
-			  (res pos)
-			  (parse-integer str :junk-allowed t)
-			(unless (and res (plusp res))
-			  (error 'namestring-parse-error
-				 :complaint "Expected a positive integer, ~
-    got ~S"
-				 :arguments (list str)
-				 :namestring namestr
-				 :offset (+ pos (cdar chunks))))
-			(setq version res)))))
-		 (when (cdr chunks)
-		   (error 'namestring-parse-error
-			  :complaint "Extra stuff after end of file name."
-			  :namestring namestr
-			  :offset (cdadr chunks)))))
-	(parse-host (logical-chunkify namestr start end)))
-      (setq directory (nreverse directory))
-      (values host
-	      (and (not (equal directory '(:absolute)))directory)
-	      name type version))))
-
-(defun extract-logical-host-prefix (namestr start end)
-  (declare (type simple-base-string namestr)
-	   (type index start end)
-	   (values (or logical-host null)))
-  (let ((colon-pos (position #\: namestr :start start :end end)))
-    (if colon-pos
-	(%str-assoc (subseq namestr start colon-pos)
-		    %logical-host-translations%)
-	nil)))
-
-(defun %parse-namestring (namestr host defaults start end junk-allowed)
-  (declare  (type string namestr)
-	   (type index start) (type (or index null) end))
-  (if junk-allowed
-      (handler-case
-	  (%parse-namestring namestr host defaults start end nil)
-	(namestring-parse-error (condition)
-	  (values nil (namestring-parse-error-offset condition))))
-      (let* ((end (or end (length namestr)))
-	     (logical-host (car (extract-logical-host-prefix namestr start end)))
-	     (parse-host (or host logical-host (pathname-host defaults))))
-	(unless parse-host
-	  (error "When Host arg is not supplied, Defaults arg must ~
-		  have a non-null PATHNAME-HOST."))
-	(if (eq host :unspecific)
-	    (setq host nil))
-	(setq host (or host logical-host))
-	(multiple-value-bind
-	    (new-host directory name type version)
-	    (if host
-		(parse-logical-namestring namestr start end)
-		(parse-unix-namestring namestr start end))
-	  (when (and host new-host (not (equal new-host host)))
-	    (error "Host in namestring: ~S~@
-		    does not match explicit host argument: ~S"
-		   (subseq namestr start end)
-		   host))
-	  (cons-pathname directory name type host version)))))
-
-
-(defun parse-namestring (thing
-			 &optional host (defaults *default-pathname-defaults*)
-			 &key (start 0) end junk-allowed)
-  (declare (type pathname defaults)
-	   (type index start)
-	   (type (or index null) end)
-	   (type (or t null) junk-allowed)
-	   (values (or null pathname) (or null index)))
-    (typecase thing
-      (simple-string
-       (%parse-namestring thing host defaults start end junk-allowed))
-      (string
-       (%parse-namestring (coerce thing 'simple-string)
-			  host defaults start end junk-allowed))
-      (pathname
-       (let ((host (if host host (%pathname-host defaults))))
-	 (unless (equal host (%pathname-host thing))
-	   (error "Hosts do not match: ~S and ~S."
-		  host (%pathname-host thing))))
-       (values thing start))
-      (stream
-       (let ((name (stream-pathname thing)))
-	 (unless name
-	   (error "Can't figure out the file associated with stream:~%  ~S"
-		  thing))
-	 name))))
-
-(defun namestring (path &key)
-  (typecase path
-    (logical-pathname (unparse-logical-namestring path))
-    (pathname (unparse-unix-namestring path))
-    (t (namestring (pathname path)))))
-
-|#
-
 ;; The following assumptions are deeply embedded in all our pathname code:
 ;; (1) Non-logical pathname host is always :unspecific.
@@ -842,5 +242,4 @@
   dirlist)
 
-; ? is (:absolute "a" :up "b") = (:absolute "b") - seems reasonable
 ; destructively mungs dir
 (defun remove-up (dir)
@@ -938,10 +337,10 @@
 	      ((nil :unspecific) "")
 	      (:wild "*")
-	      (t name))
+	      (t (%path-std-quotes name nil ".")))
 	    (if (or type version)
 	      (%str-cat (case type
 			  ((nil) ".")
 			  (:wild ".*")
-			  (t (%str-cat "." type)))
+			  (t (%str-cat "." (%path-std-quotes type nil "."))))
 			(case version
 			  ((nil) "")
@@ -1098,4 +497,11 @@
 	       (unless directory-p '(:absolute)))
 	   name type host version)))
+  (when (and (eq (car directory) :absolute)
+	     (member (cadr directory) '(:up :back)))
+    (error 'simple-file-error :pathname path :error-type "Second element of absolute directory component in ~s is ~s" :format-arguments (list (cadr directory))))
+  (let* ((after-wif (cadr (member :wild-inferiors directory))))
+    (when (member after-wif '(:up :back))
+          (error 'simple-file-error :pathname path :error-type "Directory component in ~s contains :WILD-INFERIORS followed by ~s" :format-arguments (list after-wif))))
+	 
   (when (and case (neq case :local))
     (setf (%pathname-directory path) (%reverse-component-case (%pathname-directory path) case)