- (when directory
- (go :subdir))
- :done)
- (when name
- (unless (stringp name)
- (error "non-STRING name in NATIVE-NAMESTRING: ~S" name))
- (write-string name s)
- (when type
- (unless (stringp type)
- (error "non-STRING type in NATIVE-NAMESTRING: ~S" name))
- (write-char #\. s)
- (write-string type s))))
+ (:relative)))
+ (loop for (piece . subdirs) on directory
+ do (typecase piece
+ ((member :up) (write-string ".." s))
+ (string (write-string piece s))
+ (t (error "ungood directory segment in NATIVE-NAMESTRING: ~S"
+ piece)))
+ if (or subdirs (stringp name))
+ do (write-char #\\ s)
+ else
+ do (unless as-file
+ (write-char #\\ s)))
+ (if name-present-p
+ (progn
+ (unless (stringp name-string) ;some kind of wild field
+ (error "ungood name component in NATIVE-NAMESTRING: ~S" name))
+ (write-string name-string s)
+ (when type-present-p
+ (unless (stringp type-string) ;some kind of wild field
+ (error "ungood type component in NATIVE-NAMESTRING: ~S" type))
+ (write-char #\. s)
+ (write-string type-string s)))
+ (when type-present-p ;
+ (error
+ "type component without a name component in NATIVE-NAMESTRING: ~S"
+ type)))
+ (when absolutep
+ (let ((string (get-output-stream-string s)))
+ (return-from unparse-native-win32-namestring
+ (cond ((< (- 260 12) (length string))
+ ;; KLUDGE: account for additional length of 8.3 name to make
+ ;; directories always accessible
+ (coerce string 'simple-string))
+ ((eq :unc device)
+ (replace
+ (subseq string (1- (length +unc-file-name-prefix+)))
+ "\\"))
+ (t (subseq string (length +long-file-name-prefix+))))))))