Commit 4711af84 authored by Raymond Toy's avatar Raymond Toy
Browse files

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.

  * Make SEARCH-LIST as subtype of HOST, defining appropriate parsers
    and unparsers.
  * 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.
parent 214b6ff2
......@@ -358,11 +358,12 @@
(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 ; 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)))
......@@ -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)
(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)
(list* :absolute (cddr dirs))
;;; *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).
(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."
(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
(sys::%primitive print "search list is a string!"))
(sys::%primitive print "search list is a search-list object"))
(sys::%primitive print "search list unknown type!"))))
(cond ((search-list-p search-list)
(sys::%primitive print "flame on!")
(sys::%primitive print search-pathname)
#+nil(error (intl:gettext "~S doesn't start with a search-list.") pathname))
;;; SEARCH-LIST -- public.
;;; We have to convert the internal form of the search-list back into a
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment