/[cmucl]/src/code/search-list.lisp
ViewVC logotype

Contents of /src/code/search-list.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Tue Apr 20 17:57:45 2010 UTC (4 years ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.6: +7 -7 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/search-list.lisp,v 1.7 2010/04/20 17:57:45 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Logical name (search list) hackery for Lisp'ers.
13 ;;;
14 ;;; Written by Bill Chiles.
15
16 (in-package 'lisp)
17 (in-package "EXTENSIONS")
18 (intl:textdomain "cmucl")
19
20 (export 'search-list)
21 (in-package 'lisp)
22
23
24 (defvar *search-list-table* (make-hash-table :test #'equal))
25 (defvar *rsl-circularity-check* (make-hash-table :test #'equal))
26
27
28 (defun search-list (name)
29 "Returns a list of strings that are the of name.
30 This is setf'able. If any provided string in a setting value
31 does end with a colon or slash, a slash is added. Also, the
32 list is copied."
33 (let ((dev (pathname-device name)))
34 (unless dev (error (intl:gettext "No device in ~S.") name))
35 (copy-list (gethash dev *search-list-table*))))
36
37 (defun %set-search-list (name new-value)
38 (unless (listp new-value)
39 (error (intl:gettext "New value for search-list ~S not a list -- ~S.")
40 name new-value))
41 (let ((dev (pathname-device name)))
42 (unless dev (error (intl:gettext "No device in ~S.") name))
43 (nstring-downcase dev)
44 (setf (gethash dev *search-list-table*)
45 (mapcar #'(lambda (x)
46 (let ((x (if (pathnamep x) (namestring x) x)))
47 (declare (simple-string x))
48 (let* ((len (length x))
49 (char (schar x (1- len))))
50 (if (or (char= char #\:) (char= char #\/))
51 x
52 (concatenate 'simple-string x "/")))))
53 new-value)))
54 new-value)
55
56
57 (defun resolve-search-list (name first-only-p)
58 "This takes a Sesame search-list name (\"default\") instead of the form
59 taken by SEARCH-LIST (\"default:\"). If first-only-p is non-nil, then
60 only the first complete expansion of name is returned. If, during the
61 expansion of name, an undefined search list is encountered, an error
62 is signaled."
63 (setf name (string-downcase name))
64 (setf (gethash name *rsl-circularity-check*) t)
65 (unwind-protect
66 (resolve-search-list-aux name first-only-p)
67 (clrhash *rsl-circularity-check*)))
68
69
70 ;;; RESOLVE-SEARCH-LIST-BODY is used in RESOLVE-SEARCH-LIST-AUX and
71 ;;; RSL-FIRST. This means the former is recursive, and the former and
72 ;;; latter are mutually recursive. This form first looks at an element of
73 ;;; a list of expansions for a search list for a colon which means that the
74 ;;; element needs to be further resolved. If there is no colon, execute
75 ;;; the already-form. If there is a colon, grab the new element to resolve
76 ;;; recursively. If this new element has been seen already, we have an
77 ;;; infinite recursion brewing. Recursively expand this new element. If
78 ;;; there are no expansions, signal an error with the offending search list;
79 ;;; otherwise, execute the expanded-form if the argument element was only a
80 ;;; search list, or the concat-form if the argument element was a search
81 ;;; list followed by a directory sequence. The locals pos, len, and res
82 ;;; are meant to be referenced at the call sites.
83 ;;;
84 (eval-when (compile eval)
85 (defmacro resolve-search-list-body (first-only-p element expanded-form
86 concat-form already-form)
87 `(let ((pos (position #\: ,element :test #'char=))
88 (len (length ,element)))
89 (declare (fixnum len))
90 (if pos
91 (let ((dev (nstring-downcase (subseq ,element 0 pos))))
92 (if (gethash dev *rsl-circularity-check*)
93 (error (intl:gettext "Circularity in search list -- ~S.") dev)
94 (setf (gethash dev *rsl-circularity-check*) t))
95 (let ((res (resolve-search-list-aux dev ,first-only-p)))
96 (remhash dev *rsl-circularity-check*)
97 (if res
98 (if (= (the fixnum pos) (the fixnum (1- len)))
99 ,expanded-form
100 ,concat-form)
101 (error (intl:gettext "Undefined search list -- ~S")
102 (subseq ,element 0 (1+ pos))))))
103 ,already-form)))
104 ) ; eval-when
105
106 ;;; RESOLVE-SEARCH-LIST-AUX takes a device/search-list string (that is,
107 ;;; without the colon) and whether it should return the first expansion
108 ;;; found. If dev is not defined, signal an error with the offending
109 ;;; search list. If dev is defined, and first-only-p is non-nil, then just
110 ;;; resolve the first possible expansion. Otherwise, we loop over all of
111 ;;; the possible expansions resolving each one completely, appending the
112 ;;; results in order as they appear in entry. If entry is just another
113 ;;; search list, then append the result (res) of its expansion onto result.
114 ;;; If entry is a search list followed by a directory spec, then
115 ;;; concatenate each of the expansions of the search list with the
116 ;;; directory, appending this to result. If entry is just a directory
117 ;;; spec, then append the list of entry to result.
118 ;;;
119 (defun resolve-search-list-aux (dev first-only-p)
120 (let ((entry (gethash dev *search-list-table*)))
121 (if entry
122 (if first-only-p
123 (rsl-first (car entry))
124 (do ((entries entry (cdr entries))
125 (result (cons nil nil)))
126 ((null entries) (cdr result))
127 (let ((entry (car entries)))
128 (declare (simple-string entry))
129 (resolve-search-list-body
130 nil entry (nconc result res)
131 (nconc result (rsl-concat res (subseq entry (1+ pos) len)))
132 (nconc result (list entry))))))
133 (error (intl:gettext "Undefined search list -- ~S")
134 (concatenate 'simple-string dev ":")))))
135
136 ;;; RSL-FIRST takes a possible expansion and resolves it if necessary.
137 ;;; If first is just another search list, then return the expansions
138 ;;; of this search list. If first is another search list followed by
139 ;;; directory spec, then concatenate each of the expansions of the
140 ;;; search list with the directory, returning this list. If first is
141 ;;; just a directory spec, then return the list of it.
142 ;;;
143 (defun rsl-first (first)
144 (declare (simple-string first))
145 (resolve-search-list-body t first res
146 (rsl-concat res (subseq first (1+ pos) len))
147 (list first)))
148
149 ;;; RSL-CONCAT takes a list of expansions (prefixes) for a search list
150 ;;; that was concatenated with a directory spec (suffix). Each prefix
151 ;;; is concatenated with the suffix and stored back where the prefix
152 ;;; was. The destructively modified prefixes is returned.
153 ;;;
154 (defun rsl-concat (prefixes suffix)
155 (declare (simple-string suffix))
156 (do ((ptr prefixes (cdr ptr)))
157 ((null ptr) prefixes)
158 (setf (car ptr)
159 (concatenate 'simple-string (the simple-string (car ptr)) suffix))))

  ViewVC Help
Powered by ViewVC 1.1.5