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@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