[cmucl-cvs] [git] CMU Common Lisp branch rtoy-search-list-as-host created. snapshot-2013-01-6-g4711af8

[Raymond Toy]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CMU Common Lisp".

The branch, rtoy-search-list-as-host has been created
        at  4711af8412ffff090f22421659b47781025e4291 (commit)

- Log -----------------------------------------------------------------
commit 4711af8412ffff090f22421659b47781025e4291
Author: Raymond Toy <toy.raymond at gmail.com>
Date:   Wed Jan 16 20:17:30 2013 -0800

    First cut at making search-list a pathname host.
    
    This attempts to make a search-list pathname fill the host slot of a
    pathname with a search-list object instead of the current scheme which
    uses a unix host for the host and puts the search-list as the first
    part of the directory slot.
    
     code/pathname.lisp::
      * Make SEARCH-LIST as subtype of HOST, defining appropriate parsers
        and unparsers.
     code/filesys.lisp:
      * Update PARSE-UNIX-NAMESTRING (which also handles search-lists) to
        return the search-list object as the host instead of putting in
        the directory part.

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index 308b8b5..b3362ee 100644
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -358,11 +358,12 @@
 			    name))
 	  (error 'parse-error))
 	;; Now we have everything we want.  So return it.
-	(values nil ; no host for unix namestrings.
+	(values (if search-list
+		    (intern-search-list search-list)
+		    ;; no host for unix namestrings.
+		    nil)
 		nil ; no devices for unix namestrings.
 		(collect ((dirs))
-		  (when search-list
-		    (dirs (intern-search-list search-list)))
 		  (dolist (piece pieces)
 		    (let ((piece-start (car piece))
 			  (piece-end (cdr piece)))
diff --git a/src/code/pathname.lisp b/src/code/pathname.lisp
index 0092a82..1c6d992 100644
--- a/src/code/pathname.lisp
+++ b/src/code/pathname.lisp
@@ -1503,6 +1503,14 @@ a host-structure or string."
 ;;; The SEARCH-LIST structure.
 ;;; 
 (defstruct (search-list
+	    (:include host
+	     (:parse #'parse-search-list-namestring)
+	     (:unparse #'unparse-search-list-namestring)
+	     (:unparse-host #'unparse-search-list-host)
+	     (:unparse-directory #'unparse-search-list-directory)
+	     (:unparse-file #'unparse-unix-file)
+	     (:unparse-enough #'unparse-unix-enough)
+	     (:customary-case :lower))
 	    (:print-function %print-search-list)
 	    (:make-load-form-fun
 	     (lambda (search-list)
@@ -1524,6 +1532,37 @@ a host-structure or string."
   (print-unreadable-object (sl stream :type t)
     (write-string (search-list-name sl) stream)))
 
+(defun unparse-search-list-namestring (pathname)
+  (declare (type pathname pathname))
+  (concatenate 'simple-string
+	       (unparse-search-list-directory pathname)
+	       (unparse-unix-file pathname)))
+
+(defun unparse-search-list-host (pathname)
+  (declare (type pathname pathname))
+  (search-list-name (%pathname-host pathname)))
+
+(defun unparse-search-list-directory (pathname)
+  (declare (type pathname pathname))
+  ;; FIXME: This is a hack!
+  (unparse-unix-directory-list (list* :absolute
+				      (%pathname-host pathname)
+				      (cdr (%pathname-directory pathname)))))
+
+(defun parse-search-list-namestring (pathname start end)
+  (declare (type simple-base-string namestr)
+	   (type index start end))
+  (multiple-value-bind (host device dirs name type version)
+      (parse-unix-namestring pathname start end)
+    (unless (typep (second dirs) 'search-list)
+      (error 'parse-error))
+    (values (second dirs)
+	    nil
+	    (list* :absolute (cddr dirs))
+	    name
+	    type
+	    version)))
+
 ;;; *SEARCH-LISTS* -- internal.
 ;;;
 ;;; Hash table mapping search-list names to search-list structures.
@@ -1589,6 +1628,7 @@ a host-structure or string."
 ;;; doesn't start with a search-list, then either error (if FLAME-IF-NONE
 ;;; is true) or return NIL (if FLAME-IF-NONE is false).
 ;;; 
+#+nil
 (defun extract-search-list (pathname flame-if-none)
   (with-pathname (pathname pathname)
     (let* ((directory (%pathname-directory pathname))
@@ -1600,6 +1640,28 @@ a host-structure or string."
 	    (t
 	     nil)))))
 
+(defun extract-search-list (search-pathname flame-if-none)
+  (with-pathname (pathname search-pathname)
+    (let* ((search-list (%pathname-host pathname)))
+      (when search-list
+	(sys::%primitive print "search list found")
+	(typecase search-list
+	  (string
+	   (sys::%primitive print "search list is a string!"))
+	  (search-list
+	   (sys::%primitive print "search list is a search-list object"))
+	  (t
+	   (sys::%primitive print "search list unknown type!"))))
+      (cond ((search-list-p search-list)
+	     search-list)
+	    (flame-if-none
+	     (sys::%primitive print "flame on!")
+	     (sys::%primitive print search-pathname)
+	     nil
+	     #+nil(error (intl:gettext "~S doesn't start with a search-list.") pathname))
+	    (t
+	     nil)))))
+
 ;;; SEARCH-LIST -- public.
 ;;;
 ;;; We have to convert the internal form of the search-list back into a

-----------------------------------------------------------------------


hooks/post-receive
-- 
CMU Common Lisp