Changeset 12283
- Timestamp:
- 11/25/09 23:12:39 (11 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/abcl/src/org/armedbear/lisp/pathnames.lisp
r11577 r12283 215 215 (error "Unsupported wildcard pattern: ~S" to)))) 216 216 217 (defun translate-directory-components (source from to case) 218 (cond ((null to) 219 nil 220 ) 221 ((memq (car to) '(:absolute :relative)) 222 (cons (car to) 223 (translate-directory-components (cdr source) (cdr from) (cdr to) case)) 224 ) 225 ((eq (car to) :wild) 226 (if (eq (car from) :wild) 227 ;; Grab the next chunk from SOURCE. 228 (append (casify (car source) case) 229 (translate-directory-components (cdr source) (cdr from) (cdr to) case)) 230 (error "Unsupported case 1: ~S ~S ~S" source from to)) 231 ) 232 ((eq (car to) :wild-inferiors) 233 ;; Grab the next chunk from SOURCE. 234 (append (casify (car source) case) 235 (translate-directory-components (cdr source) (cdr from) (cdr to) case)) 236 ) 237 (t 238 ;; "If the piece in TO-WILDCARD is present and not wild, it is copied 239 ;; into the result." 240 (append (casify (car to) case) 241 (translate-directory-components source from (cdr to) case)) 242 ) 243 )) 217 218 (defun translate-directory-components-aux (src from to case) 219 (cond 220 ((and (null src) (null from) (null to)) 221 NIL) 222 ((and to 223 (not (member (car to) '(:wild :wild-inferiors)))) 224 (cons (casify (car to) case) 225 (translate-directory-components-aux src from (cdr to) case))) 226 ((not (and src from)) 227 ;; both are NIL --> TO is a wildcard which can't be matched 228 ;; either is NIL --> SRC can't be fully matched against FROM, vice versa 229 (throw 'failed-match)) 230 ((not (member (car from) '(:wild :wild-inferiors))) 231 (unless (string= (casify (car src) case) (casify (car from) case)) 232 (throw 'failed-match)) ;; FROM doesn't match SRC 233 (translate-directory-components-aux (cdr src) (cdr from) to case)) 234 ((not (eq (car from) (car to))) ;; TO is NIL while FROM is not, or 235 (throw 'failed-match)) ;; FROM wildcard doesn't match TO wildcard 236 ((eq (car to) :wild) ;; FROM and TO wildcards are :WILD 237 (cons (casify (car src) case) 238 (translate-directory-components-aux (cdr src) (cdr from) (cdr to) case))) 239 ((eq (car to) :wild-inferiors) ;; FROM and TO wildcards are :WILD-INFERIORS 240 (do ((src (cdr src) (cdr src)) 241 (match (list (casify (car src) case)) 242 (cons (casify (car src) case) match))) 243 (NIL) ;; we'll exit the loop in different ways 244 (catch 'failed-match 245 (return-from translate-directory-components-aux 246 (append (reverse match) (translate-directory-components-aux 247 src (cdr from) (cdr to) case)))) 248 (when (null src) ;; SRC is NIL and we're still here: error exit 249 (throw 'failed-match)))))) 250 251 (defun translate-directory-components (src from to case) 252 (catch 'failed-match 253 (return-from translate-directory-components 254 (translate-directory-components-aux src from to case))) 255 (error "Unsupported case in TRANSLATE-DIRECTORY-COMPONENTS.")) 256 244 257 245 258 (defun translate-directory (source from to case) … … 253 266 (remove :wild-inferiors to)) 254 267 (t 255 (translate-directory-components (split-directory-components source) 256 (split-directory-components from) 257 (split-directory-components to) 258 case)))) 268 (translate-directory-components source from to case)))) 259 269 260 270 ;; "The resulting pathname is TO-WILDCARD with each wildcard or missing field
Note: See TracChangeset
for help on using the changeset viewer.