From d528f52d47243a6cc2b5bb728213b621b629ea50 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 26 Jan 2017 19:40:00 -0800 Subject: [PATCH] Make sure that strings being passed to primitives are converted. --- src/edwin/dos.scm | 6 ++-- src/edwin/xterm.scm | 5 ++- src/runtime/dosprm.scm | 52 ++++++++++++++++------------- src/runtime/dospth.scm | 4 +-- src/runtime/global.scm | 2 +- src/runtime/io.scm | 18 ++++++---- src/runtime/load.scm | 51 ++++++++++++++-------------- src/runtime/ntprm.scm | 25 ++++++++------ src/runtime/rep.scm | 2 +- src/runtime/runtime.pkg | 1 + src/runtime/savres.scm | 6 ++-- src/runtime/sfile.scm | 74 ++++++++++++++++++++++++----------------- src/runtime/socket.scm | 35 ++++++++++--------- src/runtime/unxprm.scm | 70 ++++++++++++++++++++------------------ src/runtime/unxpth.scm | 5 +-- src/runtime/ustring.scm | 6 +++- 16 files changed, 208 insertions(+), 154 deletions(-) diff --git a/src/edwin/dos.scm b/src/edwin/dos.scm index 9918813f5..9d6f5fa20 100644 --- a/src/edwin/dos.scm +++ b/src/edwin/dos.scm @@ -51,13 +51,15 @@ USA. (->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))))) diff --git a/src/edwin/xterm.scm b/src/edwin/xterm.scm index 78ff11ceb..570785ea2 100644 --- a/src/edwin/xterm.scm +++ b/src/edwin/xterm.scm @@ -1428,7 +1428,10 @@ Otherwise, it is copied from the primary selection." (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)))) diff --git a/src/runtime/dosprm.scm b/src/runtime/dosprm.scm index 38691a968..603467589 100644 --- a/src/runtime/dosprm.scm +++ b/src/runtime/dosprm.scm @@ -31,7 +31,7 @@ USA. (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 @@ -39,16 +39,16 @@ USA. (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) @@ -58,12 +58,13 @@ USA. (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?) @@ -105,7 +106,7 @@ USA. (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) @@ -133,7 +134,7 @@ USA. (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) @@ -159,7 +160,7 @@ USA. 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)))) @@ -180,7 +181,8 @@ USA. (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))) @@ -188,19 +190,20 @@ USA. (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 @@ -210,7 +213,7 @@ USA. (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*))) @@ -222,9 +225,9 @@ USA. (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 @@ -271,15 +274,17 @@ USA. (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 @@ -314,7 +319,8 @@ USA. (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 () @@ -362,7 +368,7 @@ USA. (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))))))) diff --git a/src/runtime/dospth.scm b/src/runtime/dospth.scm index 619592110..faf4d6564 100644 --- a/src/runtime/dospth.scm +++ b/src/runtime/dospth.scm @@ -401,7 +401,7 @@ USA. (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 diff --git a/src/runtime/global.scm b/src/runtime/global.scm index 64b0b5458..ad3c10029 100644 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@ -414,7 +414,7 @@ USA. (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 () diff --git a/src/runtime/io.scm b/src/runtime/io.scm index 00c93482f..7032e5bc5 100644 --- a/src/runtime/io.scm +++ b/src/runtime/io.scm @@ -285,7 +285,10 @@ USA. ;;;; 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 @@ -453,7 +456,8 @@ USA. (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)) @@ -465,7 +469,7 @@ USA. (define (directory-channel-read-matching channel prefix) ((ucode-primitive new-directory-read-matching 2) (directory-channel/descriptor channel) - prefix)) + (string-for-primitive prefix))) ;;;; Select registry @@ -687,7 +691,7 @@ USA. (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 @@ -727,8 +731,10 @@ USA. (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 diff --git a/src/runtime/load.scm b/src/runtime/load.scm index 3d60793a6..938e28cc5 100644 --- a/src/runtime/load.scm +++ b/src/runtime/load.scm @@ -179,7 +179,7 @@ USA. (values pathname (lambda () ((ucode-primitive binary-fasload) - (->namestring pathname))) + (string-for-primitive (->namestring pathname)))) (let ((notifier (loading-notifier pathname))) (lambda (thunk) (if (file-modification-timepathname 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)))) @@ -346,7 +346,7 @@ USA. (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) @@ -375,8 +375,8 @@ USA. (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 @@ -413,7 +413,8 @@ USA. (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)) @@ -423,7 +424,7 @@ USA. (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))))))) @@ -450,7 +451,7 @@ USA. (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)) @@ -539,8 +540,8 @@ USA. (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))) @@ -549,12 +550,12 @@ USA. unspecific) (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*))) @@ -569,15 +570,15 @@ USA. 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) @@ -586,19 +587,19 @@ USA. "" (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))) @@ -618,9 +619,9 @@ USA. (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))) @@ -663,11 +664,11 @@ USA. ADDITIONAL OPTIONS supported by this band:\n") (do ((parsers (sort *command-line-parsers* - (lambda (a b) (stringnamestring (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) @@ -73,12 +74,13 @@ USA. (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))))) (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) @@ -90,7 +92,8 @@ USA. (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)) @@ -141,7 +144,8 @@ USA. (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))) @@ -155,7 +159,8 @@ USA. (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) @@ -377,7 +382,7 @@ USA. '(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))) @@ -489,7 +494,7 @@ USA. (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))) diff --git a/src/runtime/rep.scm b/src/runtime/rep.scm index 6f6eb6608..40ddb5798 100644 --- a/src/runtime/rep.scm +++ b/src/runtime/rep.scm @@ -59,7 +59,7 @@ USA. (define (top-level-repl/set-default-directory cmdl pathname) cmdl ((ucode-primitive set-working-directory-pathname! 1) - (->namestring pathname))) + (string-for-primitive (->namestring pathname)))) ;;;; Command Loops diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index 6d43d5ee5..836ce2b16 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -1167,6 +1167,7 @@ USA. (make-ustring make-utf32-string) (usubstring ustring-copy) list->ustring + string-for-primitive ;export to (runtime) after 9.3 ustring ustring* ustring->ascii diff --git a/src/runtime/savres.scm b/src/runtime/savres.scm index 95ff3943f..7f122cd72 100644 --- a/src/runtime/savres.scm +++ b/src/runtime/savres.scm @@ -68,7 +68,9 @@ USA. 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)))) @@ -122,7 +124,7 @@ USA. (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 diff --git a/src/runtime/sfile.scm b/src/runtime/sfile.scm index ad80179d6..38413c58a 100644 --- a/src/runtime/sfile.scm +++ b/src/runtime/sfile.scm @@ -32,7 +32,7 @@ USA. (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))) @@ -40,7 +40,7 @@ USA. (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))) @@ -52,7 +52,10 @@ USA. (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 @@ -80,12 +83,12 @@ USA. (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) @@ -94,10 +97,10 @@ USA. (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 @@ -105,30 +108,37 @@ USA. (file-access filename 1)) (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 @@ -143,8 +153,9 @@ USA. #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)) @@ -152,7 +163,8 @@ USA. (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 '())) @@ -160,8 +172,8 @@ USA. (if name (loop (if (and (not include-dots?) - (or (string=? "." name) - (string=? ".." name))) + (or (ustring=? "." name) + (ustring=? ".." name))) result (cons name result))) (begin @@ -203,7 +215,7 @@ USA. (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) @@ -216,7 +228,7 @@ USA. (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 @@ -233,8 +245,8 @@ USA. (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))) @@ -261,7 +273,7 @@ USA. (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) @@ -271,12 +283,12 @@ USA. (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 @@ -353,7 +365,7 @@ USA. 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) @@ -364,7 +376,7 @@ USA. (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) diff --git a/src/runtime/socket.scm b/src/runtime/socket.scm index 5aee4b00d..1ed0f5a07 100644 --- a/src/runtime/socket.scm +++ b/src/runtime/socket.scm @@ -58,13 +58,16 @@ USA. (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)) @@ -121,8 +124,8 @@ USA. (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) @@ -139,12 +142,13 @@ USA. (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) @@ -177,7 +181,7 @@ USA. (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 @@ -187,7 +191,8 @@ USA. (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)) diff --git a/src/runtime/unxprm.scm b/src/runtime/unxprm.scm index 8220e4e00..a60fb76d7 100644 --- a/src/runtime/unxprm.scm +++ b/src/runtime/unxprm.scm @@ -30,11 +30,12 @@ USA. (declare (usual-integrations)) (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 @@ -59,7 +60,7 @@ USA. (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 @@ -98,11 +99,11 @@ USA. (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) @@ -130,28 +131,29 @@ USA. (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)) @@ -162,22 +164,24 @@ USA. (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!) @@ -262,8 +266,8 @@ USA. 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) @@ -317,7 +321,8 @@ USA. (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 @@ -327,7 +332,7 @@ USA. (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) @@ -342,12 +347,13 @@ USA. ;; 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) @@ -406,7 +412,7 @@ USA. (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))) @@ -417,7 +423,7 @@ USA. (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?) @@ -464,19 +470,19 @@ USA. 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) diff --git a/src/runtime/unxpth.scm b/src/runtime/unxpth.scm index b6b9b7d93..3bbecc447 100644 --- a/src/runtime/unxpth.scm +++ b/src/runtime/unxpth.scm @@ -352,5 +352,6 @@ USA. (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 diff --git a/src/runtime/ustring.scm b/src/runtime/ustring.scm index b4d9b691d..1edfc8771 100644 --- a/src/runtime/ustring.scm +++ b/src/runtime/ustring.scm @@ -698,4 +698,8 @@ USA. (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 -- 2.25.1