Treat strings returned from primitives as UTF-8 coded.

In particular, make sure that filenames are treated this way, because this is
normal for modern unix systems.  This change mostly affects filenames, but also
environment variables and command-line strings.

This is necessary because strings passed to primitives are converted to UTF-8
bytevectors.  Otherwise, a non-ASCII filename returned by a primitive won't be
converted back to the same bytes when passed to another primitive.

diff --git a/src/runtime/command-line.scm b/src/runtime/command-line.scm
index 7a6bfaab5a3206e10e452af6b13875b46675e278..fedd21fc05c166a2809de058f262f45bb004d6ad 100644 (file)
--- a/src/runtime/command-line.scm
+++ b/src/runtime/command-line.scm
@@ -33,8 +33,12 @@ USA.
  (lambda ()
    (add-event-receiver! event:after-restart process-command-line)))
 
+(define (scheme-program-name)
+  (string-from-primitive ((ucode-primitive scheme-program-name 0))))
+
 (define (command-line)
-  (vector->list ((ucode-primitive get-command-line 0))))
+  (map string-from-primitive
+       (vector->list ((ucode-primitive get-command-line 0)))))
 
 (define-deferred param:load-init-file?
   (make-settable-parameter #t))
@@ -80,7 +84,7 @@ USA.
     (set! *command-line-arguments* '())
     (let ((unused (or ((ucode-primitive get-unused-command-line 0)) '#())))
       (parameterize ((param:load-init-file? #t))
-       (process-keyword (vector->list unused) '())
+       (process-keyword (map string-from-primitive (vector->list unused)) '())
        (for-each (lambda (act) (act))
                  (reverse after-parsing-actions))
        (if (and (param:load-init-file?)

diff --git a/src/runtime/os-primitives.scm b/src/runtime/os-primitives.scm
index 7a6fee3d2d196fee4b7a68db503f3cf7ce4fa28f..4efd6d5b15b356bf06dcf387dc236ce1d140a9a7 100644 (file)
--- a/src/runtime/os-primitives.scm
+++ b/src/runtime/os-primitives.scm
@@ -54,7 +54,8 @@ USA.
 (define (reset-environment-variables!)
   (hash-table-clear! %env-cache)
   (vector-for-each (lambda (s)
-                    (let ((i (string-find-next-char s #\=)))
+                    (let ((s (string-from-primitive s))
+                          (i (string-find-next-char s #\=)))
                       (if i
                           (hash-table-set! %env-cache
                                            (string-head s i)

diff --git a/src/runtime/primitive-io.scm b/src/runtime/primitive-io.scm
index a11523db6903b5d8f4a2f2f6b6aede6df2a0a987..9a690b0b2ec541aadd5b8a55cecc11312b0b978e 100644 (file)
--- a/src/runtime/primitive-io.scm
+++ b/src/runtime/primitive-io.scm
@@ -420,8 +420,8 @@ USA.
    (lambda ()
      (let ((result ((ucode-primitive open-pty-master 0))))
        (values (make-channel (vector-ref result 0))
-              (vector-ref result 1)
-              (vector-ref result 2))))))
+              (string-from-primitive (vector-ref result 1))
+              (string-from-primitive (vector-ref result 2)))))))
 
 (define (pty-master-send-signal channel signal)
   ((ucode-primitive pty-master-send-signal 2) (channel-descriptor channel)
@@ -464,13 +464,15 @@ USA.
   (remove-from-gc-finalizer! open-directories channel))
 
 (define (directory-channel-read channel)
-  ((ucode-primitive new-directory-read 1)
-   (directory-channel/descriptor channel)))
+  (string-from-primitive
+   ((ucode-primitive new-directory-read 1)
+    (directory-channel/descriptor channel))))
 
 (define (directory-channel-read-matching channel prefix)
-  ((ucode-primitive new-directory-read-matching 2)
-   (directory-channel/descriptor channel)
-   (string-for-primitive prefix)))
+  (string-from-primitive
+   ((ucode-primitive new-directory-read-matching 2)
+    (directory-channel/descriptor channel)
+    (string-for-primitive prefix))))
 \f
 ;;;; Select registry
 

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index d365fe38d7e7ba8445a8911b0e84dcdf0695fe92..95462cd62bd8d8a92b2d2bf353746fb88373b31f 100644 (file)
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -700,7 +700,11 @@ USA.
 (define-package (runtime simple-file-ops)
   (files "sfile")
   (parent (runtime))
+  (export () deprecated:simple-file-ops
+         (file-writable? file-writeable?))
   (export ()
+         (file-exists? file-exists-indirect?)
+         (file-soft-link? file-symbolic-link?)
          <mime-type>
          allocate-temporary-file
          associate-pathname-type-with-mime-type
@@ -720,18 +724,15 @@ USA.
          file-executable?
          file-exists-direct?
          file-exists-indirect?
-         file-exists?
          file-modification-time<=?
          file-modification-time<?
          file-processed?
          file-readable?
          file-regular?
-         file-soft-link?
          file-symbolic-link?
          file-touch
          file-type-direct
          file-type-indirect
-         file-writable?
          file-writeable?
          guarantee-init-file-directory
          hard-link-file
@@ -894,6 +895,7 @@ USA.
   (parent (runtime))
   (files "os-primitives")
   (export ()
+         (file-attributes file-attributes-direct)
          copy-file
          current-home-directory
          current-user-name
@@ -904,7 +906,6 @@ USA.
          file-access-time
          file-access-time-direct
          file-access-time-indirect
-         file-attributes
          file-attributes-direct
          file-attributes-indirect
          file-attributes/access-time
@@ -1141,6 +1142,8 @@ USA.
          substring
          substring?
          vector->string)
+  (export (runtime)
+         string-from-primitive)
   (export (runtime symbol)
          %ascii-ustring!
          %ascii-ustring-allocate
@@ -3193,6 +3196,7 @@ USA.
          argument-command-line-parser
          command-line
          command-line-arguments
+         scheme-program-name
          set-command-line-parser!
          simple-command-line-parser))
 

diff --git a/src/runtime/savres.scm b/src/runtime/savres.scm
index a5953bc2b9eb4dcf468f0cece365b471c436bce8..85100d40ea824fe71fc4eda46df1e7b9edc3ab57 100644 (file)
--- a/src/runtime/savres.scm
+++ b/src/runtime/savres.scm
@@ -106,7 +106,9 @@ USA.
         (->namestring
          (if (default-object? filename)
              (merge-pathnames
-              (let ((filename ((ucode-primitive reload-band-name))))
+              (let ((filename
+                     (string-from-primitive
+                      ((ucode-primitive reload-band-name)))))
                 (if (not filename)
                     (error "no default band name available"))
                 filename))

diff --git a/src/runtime/sfile.scm b/src/runtime/sfile.scm
index 496bfb9e7a6685b2801914dfb302ada8d5ebed45..da100090f3030c563baaa24ae84cbba2f1d80f09 100644 (file)
--- a/src/runtime/sfile.scm
+++ b/src/runtime/sfile.scm
@@ -45,8 +45,6 @@ USA.
        #f
        result)))
 
-(define file-exists? file-exists-indirect?)
-
 (define file-type-direct)
 (define file-type-indirect)
 (let ((make-file-type
@@ -82,9 +80,9 @@ USA.
   (eq? 'directory (file-type-indirect filename)))
 
 (define (file-symbolic-link? filename)
-  ((ucode-primitive file-symlink? 1)
-   (string-for-primitive (->namestring (merge-pathnames filename)))))
-(define file-soft-link? file-symbolic-link?)
+  (string-from-primitive
+   ((ucode-primitive file-symlink? 1)
+    (string-for-primitive (->namestring (merge-pathnames filename))))))
 
 (define (file-access filename amode)
   ((ucode-primitive file-access 2)
@@ -102,7 +100,6 @@ USA.
           filename
           (string-for-primitive (directory-namestring pathname)))))
    2))
-(define file-writable? file-writeable?) ;upwards compatability
 
 (define (file-executable? filename)
   (file-access filename 1))

diff --git a/src/runtime/string.scm b/src/runtime/string.scm
index 54c63e5d4889b035711aaa1cef71516940972441..c2fc9a9da3fe1eca0caa45a09be007369edb9697 100644 (file)
--- a/src/runtime/string.scm
+++ b/src/runtime/string.scm
@@ -2087,6 +2087,11 @@ USA.
       string
       (string->utf8 string)))
 
+(define (string-from-primitive string)
+  (if (legacy-string? string)
+      (utf8->string (legacy-string->bytevector string))
+      string))
+
 (define-integrable (every-loop proc ref string start end)
   (let loop ((i start))
     (if (fix:< i end)

diff --git a/src/runtime/unxprm.scm b/src/runtime/unxprm.scm
index fb2c4cf9ca2d1c63a7f6d60eceee7f106fc1f124..6b88c678ec8f7a7a98059361c9a2e0b98c665943 100644 (file)
--- a/src/runtime/unxprm.scm
+++ b/src/runtime/unxprm.scm
@@ -97,16 +97,18 @@ USA.
          (error "Can't find temporary directory.")))))
 \f
 (define (file-attributes-direct filename)
-  ((ucode-primitive file-attributes 1)
-   (string-for-primitive (->namestring (merge-pathnames filename)))))
+  (let ((v
+        ((ucode-primitive file-attributes 1)
+         (string-for-primitive (->namestring (merge-pathnames filename))))))
+    (and v
+        (begin
+          (vector-set! v 0 (string-from-primitive (vector-ref v 0)))
+          v))))
 
 (define (file-attributes-indirect filename)
   ((ucode-primitive file-attributes-indirect 1)
    (string-for-primitive (->namestring (merge-pathnames filename)))))
 
-(define file-attributes
-  file-attributes-direct)
-
 (define-structure (file-attributes
                   (type vector)
                   (constructor #f)
@@ -245,7 +247,7 @@ USA.
   (let ((directory ((ucode-primitive get-user-home-directory 1) user-name)))
     (if (not directory)
        (error "Can't find user's home directory:" user-name))
-    (pathname-as-directory directory)))
+    (pathname-as-directory (string-from-primitive directory))))
 
 (define (current-home-directory)
   (let ((home (get-environment-variable "HOME")))

diff --git a/src/runtime/wrkdir.scm b/src/runtime/wrkdir.scm
index 2199edf1398742df93f9acd5fd1d039c76b050d6..4e4f18214d16d64d07c1d2256d2abefaa2a5d246 100644 (file)
--- a/src/runtime/wrkdir.scm
+++ b/src/runtime/wrkdir.scm
@@ -50,7 +50,8 @@ USA.
   (working-directory-pathname
    (pathname-simplify
     (pathname-as-directory
-     ((ucode-primitive working-directory-pathname))))))
+     (string-from-primitive
+      ((ucode-primitive working-directory-pathname)))))))
 
 (define (set-working-directory-pathname! name)
   (let ((pathname (new-pathname name)))