(define (dos/parse-namestring string host)
(call-with-values
(lambda ()
- (let ((components
- (expand-directory-prefixes
- (string-components string sub-directory-delimiters))))
- (for-each string-downcase! components)
- (parse-device-and-path components)))
+ (parse-device-and-path
+ (map ustring-downcase
+ (expand-directory-prefixes
+ (string-components string sub-directory-delimiters)))))
(lambda (device components)
(call-with-values (lambda () (parse-name (car (last-pair components))))
(lambda (name type)
(let ((components (except-last-pair components)))
(and (not (null? components))
(simplify-directory
- (if (string-null? (car components))
+ (if (fix:= 0 (ustring-length (car components)))
(cons 'ABSOLUTE
(if (and (pair? (cdr components))
- (string-null? (cadr components)))
+ (fix:= 0
+ (ustring-length
+ (cadr components))))
;; Handle "\\foo\bar" notation here:
;; the "\\foo" isn't part of the
;; directory path.
(let ((head (string-components string sub-directory-delimiters)))
(append (if (and (pair? (cdr components))
(pair? (cdr head))
- (string-null? (car (last-pair head))))
+ (fix:= 0 (ustring-length (car (last-pair head)))))
(except-last-pair head)
head)
(cdr components))))))
- (let ((end (string-length string)))
- (if (or (= 0 end)
+ (let ((end (ustring-length string)))
+ (if (or (fix:= 0 end)
(not (*expand-directory-prefixes?*)))
components
- (case (string-ref string 0)
+ (case (ustring-ref string 0)
((#\$)
- (if (= 1 end)
+ (if (fix:= 1 end)
components
(let ((value
- (get-environment-variable (substring string 1 end))))
+ (get-environment-variable (usubstring string 1 end))))
(if (not value)
components
(replace-head value)))))
(lambda ()
(if (= 1 end)
(current-home-directory)
- (user-home-directory (substring string 1 end)))))))
+ (user-home-directory (usubstring string 1 end)))))))
(if (condition? expansion)
components
(replace-head (->namestring expansion)))))
\f
(define (parse-device-and-path components)
(let ((string (car components)))
- (if (and (fix:= (string-length string) 2)
- (char=? #\: (string-ref string 1))
- (char-alphabetic? (string-ref string 0)))
- (values (string-head string 1) (cons "" (cdr components)))
+ (if (and (fix:= 2 (ustring-length string))
+ (char=? #\: (ustring-ref string 1))
+ (char-alphabetic? (ustring-ref string 0)))
+ (values (ustring-head string 1) (cons "" (cdr components)))
(values #f components))))
(define (simplify-directory directory)
(else directory)))
(define (parse-directory-components components)
- (if (there-exists? components string-null?)
+ (if (any (lambda (component)
+ (fix:= 0 (ustring-length component)))
+ components)
(error "Directory contains null component:" components))
(map parse-directory-component components))
(define (parse-directory-component component)
- (if (string=? ".." component)
+ (if (ustring=? ".." component)
'UP
component))
(define (string-components string delimiters)
- (substring-components string 0 (string-length string) delimiters))
+ (substring-components string 0 (ustring-length string) delimiters))
(define (substring-components string start end delimiters)
(let loop ((start start))
(let ((index
- (substring-find-next-char-in-set string start end delimiters)))
+ (ustring-find-first-char-in-set string delimiters start end)))
(if index
- (cons (substring string start index) (loop (fix:+ index 1)))
- (list (substring string start end))))))
+ (cons (usubstring string start index) (loop (fix:+ index 1)))
+ (list (usubstring string start end))))))
(define (parse-name string)
- (let ((dot (string-find-previous-char string #\.))
- (end (string-length string)))
+ (let ((dot (ustring-find-last-char string #\.))
+ (end (ustring-length string)))
(if (or (not dot)
(fix:= dot 0)
(fix:= dot (fix:- end 1))
- (char=? #\. (string-ref string (fix:- dot 1))))
+ (char=? #\. (ustring-ref string (fix:- dot 1))))
(values (cond ((fix:= end 0) #f)
- ((string=? "*" string) 'WILD)
+ ((ustring=? "*" string) 'WILD)
(else string))
#f)
(values (extract string 0 dot)
(extract string (fix:+ dot 1) end)))))
(define (extract string start end)
- (if (substring=? string start end "*" 0 1)
+ (if (and (fix:= 1 (fix:- end start))
+ (char=? #\* (ustring-ref string start)))
'WILD
- (substring string start end)))
+ (usubstring string start end)))
\f
;;;; Pathname Unparser
(define (dos/pathname->namestring pathname)
- (string-append (unparse-device (%pathname-device pathname))
- (unparse-directory (%pathname-directory pathname))
- (unparse-name (%pathname-name pathname)
- (%pathname-type pathname))))
+ (ustring-append (unparse-device (%pathname-device pathname))
+ (unparse-directory (%pathname-directory pathname))
+ (unparse-name (%pathname-name pathname)
+ (%pathname-type pathname))))
(define (unparse-device device)
(if (or (not device) (eq? device 'UNSPECIFIC))
""
- (string-append device ":")))
+ (ustring-append device ":")))
(define (unparse-directory directory)
(cond ((or (not directory) (eq? directory 'UNSPECIFIC))
"")
((pair? directory)
- (string-append
+ (ustring-append
(if (eq? (car directory) 'ABSOLUTE)
sub-directory-delimiter-string
"")
(let loop ((directory (cdr directory)))
(if (null? directory)
""
- (string-append (unparse-directory-component (car directory))
- sub-directory-delimiter-string
- (loop (cdr directory)))))))
+ (ustring-append (unparse-directory-component (car directory))
+ sub-directory-delimiter-string
+ (loop (cdr directory)))))))
(else
(error:illegal-pathname-component directory "directory"))))
(define (unparse-directory-component component)
(cond ((eq? component 'UP) "..")
- ((string? component) component)
+ ((ustring? component) component)
(else
(error:illegal-pathname-component component "directory component"))))
(let ((name (or (unparse-component name) ""))
(type (unparse-component type)))
(if type
- (string-append name "." type)
+ (ustring-append name "." type)
name)))
(define (unparse-component component)
- (cond ((or (not component) (string? component)) component)
+ (cond ((or (not component) (ustring? component)) component)
((eq? component 'WILD) "*")
(else (error:illegal-pathname-component component "component"))))
\f
(define (dos/make-pathname host device directory name type version)
(%%make-pathname
host
- (cond ((string? device) device)
+ (cond ((ustring? device) device)
((memq device '(#F UNSPECIFIC)) device)
(else (error:illegal-pathname-component device "device")))
(cond ((or (not directory) (eq? directory 'UNSPECIFIC))
(cddr directory)
(cdr directory))
(lambda (element)
- (if (string? element)
- (not (string-null? element))
+ (if (ustring? element)
+ (not (fix:= 0 (ustring-length element)))
(eq? element 'UP)))))
(simplify-directory directory))
(else
(error:illegal-pathname-component directory "directory")))
(if (or (memq name '(#F WILD))
- (and (string? name) (not (string-null? name))))
+ (and (ustring? name) (not (fix:= 0 (ustring-length name)))))
name
(error:illegal-pathname-component name "name"))
(if (or (memq type '(#F WILD))
- (and (string? type) (not (string-null? type))))
+ (and (ustring? type) (not (fix:= 0 (ustring-length type)))))
type
(error:illegal-pathname-component type "type"))
(if (memq version '(#F UNSPECIFIC WILD NEWEST))
(and (pair? directory)
(eq? (car directory) 'ABSOLUTE)
(pair? (cdr directory))
- (string? (cadr directory))
- (string-null? (cadr directory))))
+ (ustring? (cadr directory))
+ (fix:= 0 (ustring-length (cadr directory)))))
\f
(define (dos/directory-pathname? pathname)
(and (not (%pathname-name pathname))
(define (dos/pathname-wild? pathname)
(let ((namestring (file-namestring pathname)))
- (or (string-find-next-char namestring #\*)
- (string-find-next-char namestring #\?))))
+ (or (ustring-find-first-char namestring #\*)
+ (ustring-find-first-char namestring #\?))))
(define (dos/pathname->truename pathname)
(if (file-exists-direct? pathname)
(define (pathname-arg object defaults operator)
(cond ((pathname? object) object)
- ((string? object) (parse-namestring object #f defaults))
+ ((ustring? object) (parse-namestring object #f defaults))
(else (error:not-pathname object operator))))
(define (make-pathname host device directory name type version)
(cond ((eq? x 'WILD) "*")
((eq? x 'UP) "..")
((eq? x 'HERE) ".")
- (else (string->utf8-string x))))
+ (else x)))
(append (if (pathname-absolute? pathname)
(list "")
'())
(if (pair? path)
(let ((d (cons keyword (except-last-pair path)))
(s (car (last-pair path))))
- (if (string-null? s)
+ (if (fix:= 0 (ustring-length s))
(values d #f #f)
(let ((pn (parse-namestring s)))
(values d
(let ((scheme (uri-scheme uri))
(path
(map (lambda (x)
- (cond ((string=? x "*") 'WILD)
- ((string=? x "..") 'UP)
- ((string=? x ".") 'HERE)
- (else (utf8-string->string x))))
+ (cond ((ustring=? x "*") 'WILD)
+ ((ustring=? x "..") 'UP)
+ ((ustring=? x ".") 'HERE)
+ (else x)))
(uri-path uri)))
(lose
(lambda ()
(case scheme
((file)
(if (and (pair? path)
- (string-null? (car path)))
+ (fix:= 0 (ustring-length (car path))))
(let ((path (cdr path)))
(receive (device path)
(let ((device (pathname-device defaults)))
(if (and (not (default-object? defaults)) defaults)
defaults
(param:default-pathname-defaults))))))
- (cond ((string? namestring)
+ (cond ((ustring? namestring)
((host-type/operation/parse-namestring (host/type host))
namestring host))
((pathname? namestring)
(define (->namestring pathname)
(let ((pathname (->pathname pathname)))
- (string-append (host-namestring pathname)
- (pathname->namestring pathname))))
+ (ustring-append (host-namestring pathname)
+ (pathname->namestring pathname))))
(define (file-namestring pathname)
(pathname->namestring (file-pathname pathname)))
(define (host-namestring pathname)
(let ((host (host/name (pathname-host pathname))))
(if host
- (string-append host "::")
+ (ustring-append host "::")
"")))
(define (enough-namestring pathname #!optional defaults)
(let ((namestring (pathname->namestring pathname)))
(if (host=? (%pathname-host pathname) (%pathname-host defaults))
namestring
- (string-append (host-namestring pathname) namestring))))))
+ (ustring-append (host-namestring pathname) namestring))))))
(define (pathname->namestring pathname)
((host-type/operation/pathname->namestring
;;;; Pathname Parser
(define (unix/parse-namestring string host)
- (let ((end (string-length string)))
+ (let ((end (ustring-length string)))
(let ((components
(expand-directory-prefixes
(substring-components string 0 end #\/))))
(let ((components (except-last-pair components)))
(and (pair? components)
(simplify-directory
- (if (string=? "" (car components))
+ (if (fix:= 0
+ (ustring-length (car components)))
(cons 'ABSOLUTE
(parse-directory-components
(cdr components)))
(lambda (string)
(append (string-components string #\/)
(cdr components)))))
- (let ((end (string-length string)))
- (if (or (= 0 end)
+ (let ((end (ustring-length string)))
+ (if (or (fix:= 0 end)
(not (*expand-directory-prefixes?*)))
components
- (case (string-ref string 0)
+ (case (ustring-ref string 0)
((#\$)
- (if (= 1 end)
+ (if (fix:= 1 end)
components
(let ((value
- (get-environment-variable (substring string 1 end))))
+ (get-environment-variable (usubstring string 1 end))))
(if (not value)
components
(replace-head value)))))
(let ((expansion
(ignore-errors
(lambda ()
- (if (= 1 end)
+ (if (fix:= 1 end)
(current-home-directory)
- (user-home-directory (substring string 1 end)))))))
+ (user-home-directory (usubstring string 1 end)))))))
(if (condition? expansion)
components
(replace-head (->namestring expansion)))))
(define (parse-directory-components components)
(map parse-directory-component
- (delete-matching-items components string-null?)))
+ (remove (lambda (component)
+ (fix:= 0 (ustring-length component)))
+ components)))
(define (parse-directory-component component)
- (cond ((string=? ".." component) 'UP)
- ((string=? "." component) 'HERE)
+ (cond ((ustring=? ".." component) 'UP)
+ ((ustring=? "." component) 'HERE)
(else component)))
(define (string-components string delimiter)
- (substring-components string 0 (string-length string) delimiter))
+ (substring-components string 0 (ustring-length string) delimiter))
(define (substring-components string start end delimiter)
(let loop ((start start))
- (let ((index (substring-find-next-char string start end delimiter)))
+ (let ((index (ustring-find-first-char string delimiter start end)))
(if index
- (cons (substring string start index) (loop (+ index 1)))
- (list (substring string start end))))))
+ (cons (usubstring string start index) (loop (fix:+ index 1)))
+ (list (usubstring string start end))))))
(define (parse-name string receiver)
- (let ((end (string-length string)))
- (let ((dot (substring-find-previous-char string 0 end #\.)))
+ (let ((end (ustring-length string)))
+ (let ((dot (ustring-find-last-char string #\.)))
(if (or (not dot)
- (= dot 0)
- (= dot (- end 1))
- (char=? #\. (string-ref string (- dot 1))))
- (receiver (cond ((= end 0) #f)
- ((string=? "*" string) 'WILD)
+ (fix:= dot 0)
+ (fix:= dot (fix:- end 1))
+ (char=? #\. (ustring-ref string (fix:- dot 1))))
+ (receiver (cond ((fix:= end 0) #f)
+ ((ustring=? "*" string) 'WILD)
(else string))
#f)
(receiver (extract string 0 dot)
(extract string (+ dot 1) end))))))
(define (extract string start end)
- (if (substring=? string start end "*" 0 1)
+ (if (and (fix:= 1 (fix:- end start))
+ (char=? #\* (ustring-ref string start)))
'WILD
- (substring string start end)))
+ (usubstring string start end)))
\f
;;;; Pathname Unparser
(define (unix/pathname->namestring pathname)
- (string-append (unparse-directory (%pathname-directory pathname))
- (unparse-name (%pathname-name pathname)
- (%pathname-type pathname))))
+ (ustring-append (unparse-directory (%pathname-directory pathname))
+ (unparse-name (%pathname-name pathname)
+ (%pathname-type pathname))))
(define (unparse-directory directory)
(cond ((not directory)
"")
((pair? directory)
- (string-append
+ (ustring-append
(if (eq? (car directory) 'ABSOLUTE) "/" "")
(let loop ((directory (cdr directory)))
(if (not (pair? directory))
""
- (string-append (unparse-directory-component (car directory))
- "/"
- (loop (cdr directory)))))))
+ (ustring-append (unparse-directory-component (car directory))
+ "/"
+ (loop (cdr directory)))))))
(else
(error:illegal-pathname-component directory "directory"))))
(define (unparse-directory-component component)
(cond ((eq? component 'UP) "..")
((eq? component 'HERE) ".")
- ((string? component) component)
+ ((ustring? component) component)
(else
(error:illegal-pathname-component component "directory component"))))
(let ((name (or (unparse-component name) ""))
(type (unparse-component type)))
(if type
- (string-append name "." type)
+ (ustring-append name "." type)
name)))
(define (unparse-component component)
- (cond ((or (not component) (string? component)) component)
+ (cond ((or (not component) (ustring? component)) component)
((eq? component 'WILD) "*")
(else (error:illegal-pathname-component component "component"))))
\f
(memq (car directory) '(RELATIVE ABSOLUTE))
(list-of-type? (cdr directory)
(lambda (element)
- (if (string? element)
- (not (string-null? element))
+ (if (ustring? element)
+ (not (fix:= 0 (ustring-length element)))
(memq element '(UP HERE))))))
(simplify-directory directory))
(else
(error:illegal-pathname-component directory "directory")))
(if (or (memq name '(#F WILD))
- (and (string? name) (not (string-null? name))))
+ (and (ustring? name) (not (fix:= 0 (ustring-length name)))))
name
(error:illegal-pathname-component name "name"))
(if (or (memq type '(#F WILD))
- (and (string? type) (not (string-null? type))))
+ (and (ustring? type) (not (fix:= 0 (ustring-length type)))))
type
(error:illegal-pathname-component type "type"))
(if (memq version '(#F UNSPECIFIC WILD NEWEST))
projects / mit-scheme.git / commitdiff