(->namestring
(directory-pathname-as-file (working-directory-pathname))))
(set-working-directory-pathname! inside)
- ((ucode-primitive set-working-directory-pathname! 1) inside))
+ ((ucode-primitive set-working-directory-pathname! 1)
+ (string-for-primitive inside)))
thunk
(lambda ()
(set! inside
(->namestring
(directory-pathname-as-file (working-directory-pathname))))
- ((ucode-primitive set-working-directory-pathname! 1) outside)
+ ((ucode-primitive set-working-directory-pathname! 1)
+ (string-for-primitive outside))
(set-working-directory-pathname! outside)
(start-thread-timer)))))
(implemented-primitive-procedure?
(ucode-primitive x-open-display 1)))
(or x-display-name (get-environment-variable "DISPLAY"))
- (let ((display (x-open-display x-display-name)))
+ (let ((display
+ (x-open-display
+ (and x-display-name
+ (string-for-primitive x-display-name)))))
(set! x-display-data display)
(set! x-display-events (make-queue))
display))))
\f
(define (file-directory? filename)
((ucode-primitive file-directory? 1)
- (->namestring (merge-pathnames filename))))
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define (file-symbolic-link? filename)
filename ; ignored
(define (file-modes filename)
((ucode-primitive file-modes 1)
- (->namestring (merge-pathnames filename))))
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define (set-file-modes! filename modes)
((ucode-primitive set-file-modes! 2)
- (->namestring (merge-pathnames filename))
+ (string-for-primitive (->namestring (merge-pathnames filename)))
modes))
(define (file-access filename amode)
((ucode-primitive file-access 2)
- (->namestring (merge-pathnames filename))
+ (string-for-primitive (->namestring (merge-pathnames filename)))
amode))
;; upwards compatability
(define dos/file-access file-access)
(define (file-writeable? filename)
(let ((pathname (merge-pathnames filename)))
- (let ((filename (->namestring pathname)))
+ (let ((filename (string-for-primitive (->namestring pathname))))
(or ((ucode-primitive file-access 2) filename 2)
(and (not ((ucode-primitive file-exists? 1) filename))
((ucode-primitive file-access 2)
- (directory-namestring pathname)
+ (string-for-primitive (directory-namestring pathname))
2))))))
+
;; upwards compatability
(define file-writable? file-writeable?)
\f
(define (file-attributes filename)
((ucode-primitive file-attributes 1)
- (->namestring (merge-pathnames filename))))
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define file-attributes-direct
file-attributes)
(define (file-modification-time filename)
((ucode-primitive file-mod-time 1)
- (->namestring (merge-pathnames filename))))
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define file-modification-time-direct
file-modification-time)
access-time
(file-modification-time-direct filename))))
((ucode-primitive set-file-times! 3)
- filename
+ (string-for-primitive filename)
(or access-time time)
(or modification-time time))))
\f
(define (default-variable! var val)
(if (and (not (assoc var environment-variables))
- (not ((ucode-primitive get-environment-variable 1) var)))
+ (not ((ucode-primitive get-environment-variable 1)
+ (string-for-primitive var))))
(set! environment-variables
(cons (cons var (if (procedure? val) (val) val))
environment-variables)))
(set! get-environment-variable
(lambda (variable)
- (if (not (string? variable))
+ (if (not (ustring? variable))
(env-error 'GET-ENVIRONMENT-VARIABLE variable))
- (let ((variable (string-upcase variable)))
+ (let ((variable (ustring-upcase variable)))
(cond ((assoc variable environment-variables)
=> cdr)
(else
- ((ucode-primitive get-environment-variable 1) variable))))))
+ ((ucode-primitive get-environment-variable 1)
+ (string-for-primitive variable)))))))
(set! set-environment-variable!
(lambda (variable value)
- (if (not (string? variable))
+ (if (not (ustring? variable))
(env-error 'SET-ENVIRONMENT-VARIABLE! variable))
- (let ((variable (string-upcase variable)))
+ (let ((variable (ustring-upcase variable)))
(cond ((assoc variable environment-variables)
=> (lambda (pair) (set-cdr! pair value)))
(else
(set! delete-environment-variable!
(lambda (variable)
- (if (not (string? variable))
+ (if (not (ustring? variable))
(env-error 'DELETE-ENVIRONMENT-VARIABLE! variable))
(set-environment-variable! variable *variable-deleted*)))
(set! set-environment-variable-default!
(lambda (var val)
- (if (not (string? var))
+ (if (not (ustring? var))
(env-error 'SET-ENVIRONMENT-VARIABLE-DEFAULT! var))
- (let ((var (string-upcase var)))
+ (let ((var (ustring-upcase var)))
(cond ((assoc var environment-defaults)
=> (lambda (pair) (set-cdr! pair val)))
(else
(define (file-touch filename)
((ucode-primitive file-touch 1)
- (->namestring (merge-pathnames filename))))
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define (make-directory name)
((ucode-primitive directory-make 1)
- (->namestring (directory-pathname-as-file (merge-pathnames name)))))
+ (string-for-primitive
+ (->namestring (directory-pathname-as-file (merge-pathnames name))))))
(define (delete-directory name)
((ucode-primitive directory-delete 1)
- (->namestring (directory-pathname-as-file (merge-pathnames name)))))
+ (string-for-primitive
+ (->namestring (directory-pathname-as-file (merge-pathnames name))))))
(define (file-line-ending pathname)
pathname
(set! input-channel (file-open-input-channel input-filename))
(set! output-channel
(begin
- ((ucode-primitive file-remove-link 1) output-filename)
+ ((ucode-primitive file-remove-link 1)
+ (string-for-primitive output-filename))
(file-open-output-channel output-filename)))
unspecific)
(lambda ()
(begin
(if (not (and (pair? item)
(init-file-specifier? (car item))
- (string? (cdr item))))
+ (ustring? (cdr item))))
(error "Malformed init-file map item:" item))
(loop (cons item result)))))))
(let ((pathname*
(pathname-new-directory pathname directory*)))
(and ((ucode-primitive file-eq? 2)
- (->namestring pathname)
- (->namestring pathname*))
+ (string-for-primitive (->namestring pathname))
+ (string-for-primitive (->namestring pathname*)))
pathname*)))))
pathname)))
\ No newline at end of file
(lambda ()
(let loop ()
(if (not ((ucode-primitive primitive-fasdump)
- object filename dump-option))
+ object (string-for-primitive filename) dump-option))
(begin
(with-simple-restart 'RETRY "Try again."
(lambda ()
;;;; File Primitives
(define (file-open primitive operator filename)
- (let ((channel (open-channel (lambda (p) (primitive filename p)))))
+ (let ((channel
+ (open-channel
+ (lambda (p)
+ (primitive (string-for-primitive filename) p)))))
(if (or (channel-type=directory? channel)
(channel-type=unknown? channel))
(let ((reason
(lambda ()
(add-to-gc-finalizer! open-directories
(make-directory-channel
- ((ucode-primitive new-directory-open 1) name))))))
+ ((ucode-primitive new-directory-open 1)
+ (string-for-primitive name)))))))
(define (directory-channel-close channel)
(remove-from-gc-finalizer! open-directories channel))
(define (directory-channel-read-matching channel prefix)
((ucode-primitive new-directory-read-matching 2)
(directory-channel/descriptor channel)
- prefix))
+ (string-for-primitive prefix)))
\f
;;;; Select registry
(lambda () unspecific)
(lambda ()
((ucode-primitive dld-load-file 2)
- (and pathname (->namestring pathname))
+ (and pathname (string-for-primitive (->namestring pathname)))
p)
(let ((handle (make-dld-handle pathname (weak-cdr p))))
(with-thread-mutex-lock dld-handles-mutex
(define (dld-lookup-symbol handle name)
(guarantee-dld-handle handle 'DLD-LOOKUP-SYMBOL)
- (guarantee-string name 'DLD-LOOKUP-SYMBOL)
- ((ucode-primitive dld-lookup-symbol 2) (dld-handle-address handle) name))
+ (guarantee ustring? name 'DLD-LOOKUP-SYMBOL)
+ ((ucode-primitive dld-lookup-symbol 2)
+ (dld-handle-address handle)
+ (string-for-primitive name)))
(define (dld-loaded-file? pathname)
(find-dld-handle
(values pathname
(lambda ()
((ucode-primitive binary-fasload)
- (->namestring pathname)))
+ (string-for-primitive (->namestring pathname))))
(let ((notifier (loading-notifier pathname)))
(lambda (thunk)
(if (file-modification-time<?
(define (object-file? pathname)
(and (let ((type (pathname-type pathname)))
- (and (string? type)
- (string=? type "so")))
+ (and (ustring? type)
+ (ustring=? type "so")))
(file-regular? pathname)))
(define (load/purification-root object)
(lambda ()
(let ((handle (dld-load-file (standard-uri->pathname uri))))
(let ((nonce* (liarc-object-file-nonce handle)))
- (if (not (and nonce* (string=? nonce* nonce)))
+ (if (not (and nonce* (ustring=? nonce* nonce)))
(begin
(dld-unload-file handle)
(error "Can't restore liarc object file:" uri))))
(lambda ()
((ucode-primitive address-to-string 1)
(dld-lookup-symbol handle "dload_nonce"))))))
- (and (string? nonce)
+ (and (ustring? nonce)
nonce)))
(define (initialize-object-file handle uri)
(if (and (equal? p
'("" "software" "mit-scheme"
"lib" "lib"))
- (string-suffix? ".so" s))
- (list (string-head s (fix:- (string-length s) 3)))
+ (ustring-suffix? ".so" s))
+ (list (ustring-head s (fix:- (ustring-length s) 3)))
'())
(list ""))))
#f
(lambda (uri)
(reverse! (let ((rp (reverse (uri-path uri))))
(if (and (pair? rp)
- (string-null? (car rp)))
+ (fix:= 0
+ (ustring-length (car rp))))
(cdr rp)
rp))))))
(and (eq? (uri-scheme uri) (uri-scheme lib))
(let loop ((pu (trim-path uri)) (pl (trim-path lib)))
(if (pair? pl)
(and (pair? pu)
- (string=? (car pu) (car pl))
+ (ustring=? (car pu) (car pl))
(loop (cdr pu) (cdr pl)))
(make-pathname #f #f (cons 'RELATIVE pu)
#f #f #f)))))))
(standard-library-directory-pathname))))
(define (system-uri #!optional rel-uri)
- (if (string? system-base-uri)
+ (if (ustring? system-base-uri)
(begin
(set! system-base-uri (string->uri system-base-uri))
unspecific))
(cddr entry))))
(define (option-keyword? argument)
- (and (fix:> (string-length argument) 1)
- (char=? #\- (string-ref argument 0))))
+ (and (fix:> (ustring-length argument) 1)
+ (char=? #\- (ustring-ref argument 0))))
(define (load-init-file)
(let ((pathname (init-file-pathname)))
unspecific)
\f
(define (set-command-line-parser! keyword proc #!optional description)
- (guarantee string? keyword 'SET-COMMAND-LINE-PARSER!)
+ (guarantee ustring? keyword 'SET-COMMAND-LINE-PARSER!)
(let ((keyword (strip-leading-hyphens keyword))
(desc (if (default-object? description)
""
(begin
- (guarantee string? description 'SET-COMMAND-LINE-PARSER!)
+ (guarantee ustring? description 'SET-COMMAND-LINE-PARSER!)
description))))
(let ((place (assoc keyword *command-line-parsers*)))
unspecific)))))
(define (strip-leading-hyphens keyword)
- (let ((end (string-length keyword)))
+ (let ((end (ustring-length keyword)))
(let loop ((start 0))
(cond ((and (fix:< start end)
- (char=? #\- (string-ref keyword start)))
+ (char=? #\- (ustring-ref keyword start)))
(loop (fix:+ start 1)))
((fix:= start 0)
keyword)
(else
- (substring keyword start end))))))
+ (usubstring keyword start end))))))
(define (command-line-option-description keyword-line description-lines caller)
(if (pair? description-lines)
""
(begin
(for-each (lambda (description-line)
- (guarantee string? description-line caller))
+ (guarantee ustring? description-line caller))
description-lines)
(decorated-string-append "" "\n " ""
(cons keyword-line description-lines))))
- (string-append keyword-line "\n (No description.)")))
+ (ustring-append keyword-line "\n (No description.)")))
(define (simple-command-line-parser keyword thunk . description-lines)
- (guarantee string? keyword 'SIMPLE-COMMAND-LINE-PARSER)
+ (guarantee ustring? keyword 'SIMPLE-COMMAND-LINE-PARSER)
(set-command-line-parser! keyword
(lambda (command-line)
(values (cdr command-line) thunk))
(command-line-option-description
- (string-append "--" keyword)
+ (ustring-append "--" keyword)
description-lines
'SIMPLE-COMMAND-LINE-PARSER)))
(values '()
(lambda ()
(warn "Missing argument to command-line option:"
- (string-append "--" keyword)))))))
+ (ustring-append "--" keyword)))))))
(command-line-option-description
- (string-append "--" keyword " ARG" (if multiple? " ..." ""))
+ (ustring-append "--" keyword " ARG" (if multiple? " ..." ""))
description-lines
'ARGUMENT-COMMAND-LINE-PARSER)))
ADDITIONAL OPTIONS supported by this band:\n")
(do ((parsers (sort *command-line-parsers*
- (lambda (a b) (string<? (car a) (car b))))
+ (lambda (a b) (ustring<? (car a) (car b))))
(cdr parsers)))
((null? parsers))
(let ((description (cadar parsers)))
- (if (not (string-null? description))
+ (if (not (fix:= 0 (ustring-length description)))
(begin
(newline)
(write-string description)
(declare (usual-integrations))
\f
(define (file-modes filename)
- ((ucode-primitive file-modes 1) (->namestring (merge-pathnames filename))))
+ ((ucode-primitive file-modes 1)
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define (set-file-modes! filename modes)
((ucode-primitive set-file-modes! 2)
- (->namestring (merge-pathnames filename))
+ (string-for-primitive (->namestring (merge-pathnames filename)))
modes))
(define-integrable nt-file-mode/read-only #x001)
(file-attributes/length attr))))
(define (copy-file from to)
- ((ucode-primitive nt-copy-file 2) (->namestring (merge-pathnames from))
- (->namestring (merge-pathnames to))))
+ ((ucode-primitive nt-copy-file 2)
+ (string-for-primitive (->namestring (merge-pathnames from)))
+ (string-for-primitive (->namestring (merge-pathnames to)))))
\f
(define (file-modification-time filename)
((ucode-primitive file-mod-time 1)
- (->namestring (merge-pathnames filename))))
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define file-modification-time-direct file-modification-time)
(define file-modification-time-indirect file-modification-time)
(define file-access-time-indirect file-modification-time-indirect)
(define (set-file-times! filename access-time modification-time)
- (let ((filename (->namestring (merge-pathnames filename))))
+ (let ((filename
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
((ucode-primitive set-file-times! 3)
filename
(or access-time (file-access-time filename))
(define (default-variable! var val)
(if (and (not (assoc var environment-variables))
- (not ((ucode-primitive get-environment-variable 1) var)))
+ (not ((ucode-primitive get-environment-variable 1)
+ (string-for-primitive var))))
(set! environment-variables
(cons (cons var (if (procedure? val) (val) val))
environment-variables)))
(cond ((assoc variable environment-variables)
=> cdr)
(else
- ((ucode-primitive get-environment-variable 1) variable))))))
+ ((ucode-primitive get-environment-variable 1)
+ (string-for-primitive variable)))))))
(set! set-environment-variable!
(lambda (variable value)
'(ABSOLUTE))))
(let ((info
((ucode-primitive nt-get-volume-information 1)
- (->namestring root))))
+ (string-for-primitive (->namestring root)))))
(if (not info)
(error "Error reading volume information:" root))
info)))
(if ctty
(error "Can't manipulate controlling terminal of subprocess:" ctty))
((ucode-primitive nt-make-subprocess 8)
- filename
+ (string-for-primitive filename)
(rewrite-args filename (vector->list arguments))
(and environment
(rewrite-env (vector->list environment)))
(define (top-level-repl/set-default-directory cmdl pathname)
cmdl
((ucode-primitive set-working-directory-pathname! 1)
- (->namestring pathname)))
+ (string-for-primitive (->namestring pathname))))
\f
;;;; Command Loops
(make-ustring make-utf32-string)
(usubstring ustring-copy)
list->ustring
+ string-for-primitive ;export to (runtime) after 9.3
ustring
ustring*
ustring->ascii
interrupt-mask
(gc-flip)
(do ()
- (((ucode-primitive dump-band) restart filename))
+ (((ucode-primitive dump-band)
+ restart
+ (string-for-primitive filename)))
(with-simple-restart 'RETRY "Try again."
(lambda ()
(error "Disk save failed:" filename))))
(or (try pathname)
(system-library-pathname pathname))))))))))
(event-distributor/invoke! event:before-exit)
- ((ucode-primitive load-band) filename)))
+ ((ucode-primitive load-band) (string-for-primitive filename))))
(define (identify-world #!optional port)
(let ((port
(define (file-exists-direct? filename)
(let ((result
((ucode-primitive file-exists-direct? 1)
- (->namestring (merge-pathnames filename)))))
+ (string-for-primitive (->namestring (merge-pathnames filename))))))
(if (eq? 0 result)
#t
result)))
(define (file-exists-indirect? filename)
(let ((result
((ucode-primitive file-exists? 1)
- (->namestring (merge-pathnames filename)))))
+ (string-for-primitive (->namestring (merge-pathnames filename))))))
(if (eq? 0 result)
#f
result)))
(let ((make-file-type
(lambda (procedure)
(lambda (filename)
- (let ((n (procedure (->namestring (merge-pathnames filename)))))
+ (let ((n
+ (procedure
+ (string-for-primitive
+ (->namestring (merge-pathnames filename))))))
(and n
(let ((types
'#(REGULAR
(define (file-symbolic-link? filename)
((ucode-primitive file-symlink? 1)
- (->namestring (merge-pathnames filename))))
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define file-soft-link? file-symbolic-link?)
(define (file-access filename amode)
((ucode-primitive file-access 2)
- (->namestring (merge-pathnames filename))
+ (string-for-primitive (->namestring (merge-pathnames filename)))
amode))
(define (file-readable? filename)
(define (file-writeable? filename)
((ucode-primitive file-access 2)
(let ((pathname (merge-pathnames filename)))
- (let ((filename (->namestring pathname)))
+ (let ((filename (string-for-primitive (->namestring pathname))))
(if ((ucode-primitive file-exists? 1) filename)
filename
- (directory-namestring pathname))))
+ (string-for-primitive (directory-namestring pathname)))))
2))
(define file-writable? file-writeable?) ;upwards compatability
(file-access filename 1))
\f
(define (file-touch filename)
- ((ucode-primitive file-touch 1) (->namestring (merge-pathnames filename))))
+ ((ucode-primitive file-touch 1)
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define (make-directory name)
((ucode-primitive directory-make 1)
- (->namestring (directory-pathname-as-file (merge-pathnames name)))))
+ (string-for-primitive
+ (->namestring (directory-pathname-as-file (merge-pathnames name))))))
(define (delete-directory name)
((ucode-primitive directory-delete 1)
- (->namestring (directory-pathname-as-file (merge-pathnames name)))))
+ (string-for-primitive
+ (->namestring (directory-pathname-as-file (merge-pathnames name))))))
(define (rename-file from to)
- ((ucode-primitive file-rename) (->namestring (merge-pathnames from))
- (->namestring (merge-pathnames to))))
+ ((ucode-primitive file-rename)
+ (string-for-primitive (->namestring (merge-pathnames from)))
+ (string-for-primitive (->namestring (merge-pathnames to)))))
(define (delete-file filename)
- ((ucode-primitive file-remove) (->namestring (merge-pathnames filename))))
+ ((ucode-primitive file-remove)
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define (hard-link-file from to)
- ((ucode-primitive file-link-hard 2) (->namestring (merge-pathnames from))
- (->namestring (merge-pathnames to))))
+ ((ucode-primitive file-link-hard 2)
+ (string-for-primitive (->namestring (merge-pathnames from)))
+ (string-for-primitive (->namestring (merge-pathnames to)))))
(define (soft-link-file from to)
- ((ucode-primitive file-link-soft 2) (->namestring from)
- (->namestring (merge-pathnames to))))
+ ((ucode-primitive file-link-soft 2)
+ (string-for-primitive (->namestring from))
+ (string-for-primitive (->namestring (merge-pathnames to)))))
(define (delete-file-no-errors filename)
(call-with-current-continuation
#t)))))
(define (file-eq? x y)
- ((ucode-primitive file-eq?) (->namestring (merge-pathnames x))
- (->namestring (merge-pathnames y))))
+ ((ucode-primitive file-eq?)
+ (string-for-primitive (->namestring (merge-pathnames x)))
+ (string-for-primitive (->namestring (merge-pathnames y)))))
(define (current-file-time)
(call-with-temporary-file-pathname file-modification-time))
(define (directory-file-names directory #!optional include-dots?)
(let ((channel
(directory-channel-open
- (->namestring (pathname-as-directory directory))))
+ (string-for-primitive
+ (->namestring (pathname-as-directory directory)))))
(include-dots?
(if (default-object? include-dots?) #f include-dots?)))
(let loop ((result '()))
(if name
(loop
(if (and (not include-dots?)
- (or (string=? "." name)
- (string=? ".." name)))
+ (or (ustring=? "." name)
+ (ustring=? ".." name)))
result
(cons name result)))
(begin
(define (allocate-temporary-file pathname)
(and (not (file-exists? pathname))
(let ((updater (fixed-objects-updater 'files-to-delete))
- (filename (->namestring pathname)))
+ (filename (string-for-primitive (->namestring pathname))))
(with-files-to-delete-locked
(lambda ()
(and (file-touch pathname)
(define (deallocate-temporary-file pathname)
(delete-file-no-errors pathname)
(let ((updater (fixed-objects-updater 'files-to-delete))
- (filename (->namestring pathname)))
+ (filename (string-for-primitive (->namestring pathname))))
(with-files-to-delete-locked
(lambda ()
(updater
(and (list? object)
(for-all? object
(lambda (object)
- (and (string? object)
- (not (string-null? object)))))))
+ (and (ustring? object)
+ (not (fix:= 0 (ustring-length object))))))))
(define (guarantee-init-file-directory pathname)
(let ((directory (user-homedir-pathname)))
(pathname-type->mime-type (pathname-type pathname)))
(define (pathname-type->mime-type type)
- (and (string? type)
+ (and (ustring? type)
(let ((mime-type (hash-table/get local-type-map type #f)))
(if mime-type
(and (mime-type? mime-type)
(string->mime-type string)))))))
(define (associate-pathname-type-with-mime-type type mime-type)
- (guarantee-string type 'ASSOCIATE-PATHNAME-TYPE-WITH-MIME-TYPE)
+ (guarantee ustring? type 'ASSOCIATE-PATHNAME-TYPE-WITH-MIME-TYPE)
(guarantee-mime-type mime-type 'ASSOCIATE-PATHNAME-TYPE-WITH-MIME-TYPE)
(hash-table/put! local-type-map type mime-type))
(define (disassociate-pathname-type-from-mime-type type)
- (guarantee-string type 'DISASSOCIATE-PATHNAME-TYPE-FROM-MIME-TYPE)
+ (guarantee ustring? type 'DISASSOCIATE-PATHNAME-TYPE-FROM-MIME-TYPE)
(hash-table/put! local-type-map type 'DISASSOCIATED))
(define-record-type <mime-type>
0))
(define (mime-type-string? object)
- (and (string? object)
+ (and (ustring? object)
(string-is-mime-type? object)))
(define (string-is-mime-type? string #!optional start end)
(string-is-mime-token? (symbol-name object))))
(define (mime-token-string? object)
- (and (string? object)
+ (and (ustring? object)
(string-is-mime-token? object)))
(define (string-is-mime-token? string #!optional start end)
(define (tcp-service->port service)
(if (exact-nonnegative-integer? service)
((ucode-primitive get-service-by-number 1) service)
- ((ucode-primitive get-service-by-name 2) service "tcp")))
+ ((ucode-primitive get-service-by-name 2)
+ (string-for-primitive service)
+ (string-for-primitive "tcp"))))
(define (open-unix-server-socket pathname)
- (open-channel
- (lambda (p)
- ((ucode-primitive create-unix-server-socket 2) (->namestring pathname) p)
- #t)))
+ (let ((filename (string-for-primitive (->namestring pathname))))
+ (open-channel
+ (lambda (p)
+ ((ucode-primitive create-unix-server-socket 2) filename p)
+ #t))))
(define (close-tcp-server-socket server-socket)
(channel-close server-socket))
(let ((channel (open-tcp-stream-socket-channel host-name service)))
(make-socket-port channel 'open-tcp-stream-socket)))
-(define (open-unix-stream-socket filename)
- (let ((channel (open-unix-stream-socket-channel filename)))
+(define (open-unix-stream-socket pathname)
+ (let ((channel (open-unix-stream-socket-channel pathname)))
(make-socket-port channel 'open-unix-stream-socket)))
(define (open-tcp-stream-socket-channel host-name service)
(lambda ()
((ucode-primitive new-open-tcp-stream-socket 3) host port p)))))))
-(define (open-unix-stream-socket-channel filename)
- (open-channel
- (lambda (p)
- (with-thread-timer-stopped
- (lambda ()
- ((ucode-primitive new-open-unix-stream-socket 2) filename p))))))
+(define (open-unix-stream-socket-channel pathname)
+ (let ((filename (string-for-primitive (->namestring pathname))))
+ (open-channel
+ (lambda (p)
+ (with-thread-timer-stopped
+ (lambda ()
+ ((ucode-primitive new-open-unix-stream-socket 2) filename p)))))))
(define (make-socket-port channel caller)
(make-generic-i/o-port (make-channel-input-source channel)
(define (get-host-by-name host-name)
(with-thread-timer-stopped
(lambda ()
- ((ucode-primitive get-host-by-name 1) host-name))))
+ ((ucode-primitive get-host-by-name 1) (string-for-primitive host-name)))))
(define (get-host-by-address host-address)
(with-thread-timer-stopped
(define (canonical-host-name host-name)
(with-thread-timer-stopped
(lambda ()
- ((ucode-primitive canonical-host-name 1) host-name))))
+ ((ucode-primitive canonical-host-name 1)
+ (string-for-primitive host-name)))))
(define get-host-name
(ucode-primitive get-host-name 0))
(declare (usual-integrations))
\f
(define (file-modes filename)
- ((ucode-primitive file-modes 1) (->namestring (merge-pathnames filename))))
+ ((ucode-primitive file-modes 1)
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define-integrable (set-file-modes! filename modes)
((ucode-primitive set-file-modes! 2)
- (->namestring (merge-pathnames filename))
+ (string-for-primitive (->namestring (merge-pathnames filename)))
modes))
(define unix/file-access file-access) ;upwards compatability
(let loop ((ext 0))
(let ((pathname
(transformer
- (merge-pathnames (string-append root-string (number->string ext))
+ (merge-pathnames (ustring-append root-string (number->string ext))
directory))))
(if (allocate-temporary-file pathname)
(begin
\f
(define (file-attributes-direct filename)
((ucode-primitive file-attributes 1)
- (->namestring (merge-pathnames filename))))
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define (file-attributes-indirect filename)
((ucode-primitive file-attributes-indirect 1)
- (->namestring (merge-pathnames filename))))
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define file-attributes
file-attributes-direct)
(define (file-modification-time-direct filename)
((ucode-primitive file-mod-time 1)
- (->namestring (merge-pathnames filename))))
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define (file-modification-time-indirect filename)
((ucode-primitive file-mod-time-indirect 1)
- (->namestring (merge-pathnames filename))))
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define file-modification-time
file-modification-time-indirect)
(define (file-access-time-direct filename)
((ucode-primitive file-access-time 1)
- (->namestring (merge-pathnames filename))))
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define (file-access-time-indirect filename)
((ucode-primitive file-access-time-indirect 1)
- (->namestring (merge-pathnames filename))))
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
(define file-access-time
file-access-time-indirect)
(define (set-file-times! filename access-time modification-time)
- (let ((filename (->namestring (merge-pathnames filename))))
+ (let ((filename
+ (string-for-primitive (->namestring (merge-pathnames filename)))))
((ucode-primitive set-file-times! 3)
filename
(or access-time (file-access-time-direct filename))
(define environment-variables)
(define (get-environment-variable name)
- (guarantee-string name 'GET-ENVIRONMENT-VARIABLE)
+ (guarantee ustring? name 'GET-ENVIRONMENT-VARIABLE)
(let ((value (hash-table/get environment-variables name 'NONE)))
(if (eq? value 'NONE)
- (let ((value ((ucode-primitive get-environment-variable 1) name)))
+ (let ((value
+ ((ucode-primitive get-environment-variable 1)
+ (string-for-primitive name))))
(hash-table/put! environment-variables name value)
value)
value)))
(define (set-environment-variable! name value)
- (guarantee-string name 'SET-ENVIRONMENT-VARIABLE!)
+ (guarantee ustring? name 'SET-ENVIRONMENT-VARIABLE!)
(if value
- (guarantee-string value 'SET-ENVIRONMENT-VARIABLE!))
+ (guarantee ustring? value 'SET-ENVIRONMENT-VARIABLE!))
(hash-table/put! environment-variables name value))
(define (delete-environment-variable! name)
- (guarantee-string name 'DELETE-ENVIRONMENT-VARIABLE!)
+ (guarantee ustring? name 'DELETE-ENVIRONMENT-VARIABLE!)
(hash-table/remove! environment-variables name))
(define (reset-environment-variables!)
entries)))))))))
(define (parse-mime.types-line line)
- (if (and (fix:> (string-length line) 0)
- (char=? (string-ref line 0) #\#))
+ (if (and (fix:> (ustring-length line) 0)
+ (char=? #\# (ustring-ref line 0)))
#f
(let ((parts (burst-string line char-set:whitespace #t)))
(and (pair? parts)
(number->string gid 10)))
(define (unix/system string)
- (let ((wd-inside (->namestring (working-directory-pathname)))
+ (let ((wd-inside
+ (string-for-primitive (->namestring (working-directory-pathname))))
(wd-outside)
(ti-outside))
(dynamic-wind
(set! ti-outside (thread-timer-interval))
(set-thread-timer-interval! #f))
(lambda ()
- ((ucode-primitive system 1) string))
+ ((ucode-primitive system 1) (string-for-primitive string)))
(lambda ()
((ucode-primitive set-working-directory-pathname! 1) wd-outside)
(set! wd-outside)
;; Linux kernel), and ISO9660 can be either DOS or unix format.
(let ((type
((ucode-primitive file-system-type 1)
- (->namestring
- (let loop ((pathname (merge-pathnames pathname)))
- (if (file-exists? pathname)
- pathname
- (loop (directory-pathname-as-file
- (directory-pathname pathname)))))))))
+ (string-for-primitive
+ (->namestring
+ (let loop ((pathname (merge-pathnames pathname)))
+ (if (file-exists? pathname)
+ pathname
+ (loop (directory-pathname-as-file
+ (directory-pathname pathname))))))))))
(if (or (string-ci=? "fat" type)
(string-ci=? "hpfs" type)
(string-ci=? "iso9660" type)
(define (init-file-specifier->pathname specifier)
(guarantee-init-file-specifier specifier 'INIT-FILE-SPECIFIER->PATHNAME)
- (merge-pathnames (apply string-append
+ (merge-pathnames (apply ustring-append
(cons ".mit-scheme"
(append-map (lambda (string) (list "/" string))
specifier)))
(define (os/make-subprocess filename arguments environment working-directory
ctty stdin stdout stderr)
((ucode-primitive ux-make-subprocess 8)
- filename arguments environment working-directory
+ (string-for-primitive filename) arguments environment working-directory
ctty stdin stdout stderr))
(define (os/find-program program default-directory #!optional exec-path error?)
path)))
(define (os/parse-path-string string)
- (let ((end (string-length string))
+ (let ((end (ustring-length string))
(substring
(lambda (string start end)
- (pathname-as-directory (substring string start end)))))
+ (pathname-as-directory (usubstring string start end)))))
(let loop ((start 0))
(if (< start end)
- (let ((index (substring-find-next-char string start end #\:)))
+ (let ((index (ustring-find-first-char string #\: start end)))
(if index
(cons (if (= index start)
#f
- (substring string start index))
+ (usubstring string start index))
(loop (+ index 1)))
- (list (substring string start end))))
+ (list (usubstring string start end))))
'()))))
(define (os/shell-file-name)
(cons (car p*) (loop (cdr p*))))))
(define (file-eq? p1 p2)
- ((ucode-primitive file-eq? 2) (->namestring (merge-pathnames p1))
- (->namestring (merge-pathnames p2))))
\ No newline at end of file
+ ((ucode-primitive file-eq? 2)
+ (string-for-primitive (->namestring (merge-pathnames p1)))
+ (string-for-primitive (->namestring (merge-pathnames p2)))))
\ No newline at end of file
(symbol? object)
(pathname? object)
(number? object)
- (uri? object)))
\ No newline at end of file
+ (uri? object)))
+
+(define (string-for-primitive string)
+ (or (ustring->ascii string)
+ (string->utf8 string)))
\ No newline at end of file
projects / mit-scheme.git / commitdiff