[racket-dev] [plt] Push #28897: master branch updated
Commit 5b028396df6b80ab0a4333b8fc929f1f8d1f15b3 looks like the right
fix, thanks for that.
On Wed, Jun 18, 2014 at 10:21 PM, <mflatt at racket-lang.org> wrote:
> mflatt has updated `master' from 3831cb135e to 5b028396df.
> http://git.racket-lang.org/plt/3831cb135e..5b028396df
>
> =====[ 7 Commits ]======================================================
> Directory summary:
> 10.6% pkgs/racket-pkgs/racket-doc/scribblings/reference/
> 23.3% pkgs/racket-pkgs/racket-test/tests/racket/
> 59.9% racket/src/racket/src/
> 3.7% racket/src/racket/
>
> ~~~~~~~~~~
>
> 2193d2a Matthew Flatt <mflatt at racket-lang.org> 2014-06-18 07:28:28 +0100
> :
> | optimizer: add missing "else"
> |
> | Thanks to David Vanderson
> :
> M racket/src/racket/src/optimize.c | 2 +-
>
> ~~~~~~~~~~
>
> c8c0972 Matthew Flatt <mflatt at racket-lang.org> 2014-06-18 00:23
> :
> | ignore .sl.cache files
> |
> | Created by `msbuild`?
> :
> M racket/src/worksp/.gitignore | 1 +
>
> ~~~~~~~~~~
>
> 3e3cb71 Matthew Flatt <mflatt at racket-lang.org> 2014-06-18 00:26
> :
> | win32: support symbolic links
> |
> | Windows supports symbolic links in Vista and later.
> :
> M .../racket-doc/scribblings/reference/paths.scrbl | 22 +-
> M racket/src/racket/sconfig.h | 44 ---
> M racket/src/racket/src/file.c | 371 +++++++++++++++----
> M .../scribblings/reference/filesystem.scrbl | 17 +-
> M .../scribblings/reference/windows-paths.scrbl | 7 +
>
> ~~~~~~~~~~
>
> e1c735f Matthew Flatt <mflatt at racket-lang.org> 2014-06-18 09:30:58 +0100
> :
> | win64: fix fixnum-to-extfl conversion
> :
> M native-pkgs | 2 +-
> M racket/src/racket/src/jitarith.c | 2 +-
> M racket/src/racket/src/longdouble/longdouble.c | 14 +++++++++++++-
> M racket/src/racket/src/longdouble/longdouble.h | 2 ++
> M racket/src/racket/src/number.c | 8 ++++----
> M racket/src/racket/src/ratfloat.inc | 9 +++++----
> M racket/src/racket/src/rational.c | 9 ++++++---
>
> ~~~~~~~~~~
>
> 9fed5b5 Matthew Flatt <mflatt at racket-lang.org> 2014-06-18 22:12
> :
> | windows: fix symbolic link handling to match the OS
> |
> | Windows parses relative-path links with yet another set of rules ---
> | slightly different from the many other existing rules for parsing
> | paths. Unfortunately, a few OS calls don't provide an option for
> | having the OS follow links, so we have to re-implement (our best guess
> | at) the OS's parsing of links.
> :
> A pkgs/racket-pkgs/racket-test/tests/racket/win-link.rkt
> M .../racket-doc/scribblings/reference/paths.scrbl | 10 +-
> M racket/src/racket/src/file.c | 132 +++++++++++++++----
> M .../scribblings/reference/filesystem.scrbl | 5 +-
> M .../scribblings/reference/windows-paths.scrbl | 5 +-
>
> ~~~~~~~~~~
>
> 54c9057 Matthew Flatt <mflatt at racket-lang.org> 2014-06-19 05:26:59 +0100
> :
> | distro-build: allow any string for `#:vc`
> :
> M pkgs/distro-build-pkgs/distro-build-client/doc.txt | 5 +++--
> M pkgs/distro-build-pkgs/distro-build-server/config.rkt | 2 +-
>
> ~~~~~~~~~~
>
> 5b02839 Matthew Flatt <mflatt at racket-lang.org> 2014-06-19 05:55:30 +0100
> :
> | unbreak build
> |
> | I have no idea whether the change is generally right, but it allows
> | the build to complete and DrRacket to start.
> :
> M .../typed-racket-lib/typed-racket/base-env/base-env.rkt | 2 +-
>
> =====[ Overall Diff ]===================================================
>
> native-pkgs
> ~~~~~~~~~~~
> --- OLD/native-pkgs
> +++ NEW/native-pkgs
> @@ -1 +1 @@
> -Subproject commit a4521921cea66170c4b55373cda6191fb47730d5
> +Subproject commit 60c510ba85d702163b317423f3c20f6fd80278c0
>
> pkgs/distro-build-pkgs/distro-build-client/doc.txt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/distro-build-pkgs/distro-build-client/doc.txt
> +++ NEW/pkgs/distro-build-pkgs/distro-build-client/doc.txt
> @@ -215,8 +215,9 @@ Site-configuration keywords (where <string*> means no spaces, etc.):
>
> #:bits <integer> --- 32 or 64, affects Visual Studio mode
>
> - #:vc <string*> --- "x86" or "x64" to select the Visual Studio build
> - mode; default depends on `#:bits'
> + #:vc <string*> --- provided to "vcvarsall/bat" to select the Visual
> + Studio build mode; the default is "x86" or "x64", depending on
> + `#:bits'
>
> #:sign-identity <string> --- provides an identity to be passed to
> `codesign` for code signing on Mac OS X (for all executables in a
>
> pkgs/distro-build-pkgs/distro-build-server/config.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/distro-build-pkgs/distro-build-server/config.rkt
> +++ NEW/pkgs/distro-build-pkgs/distro-build-server/config.rkt
> @@ -134,7 +134,7 @@
> [(#:platform) (memq val '(unix macosx windows windows/bash))]
> [(#:configure) (and (list? val) (andmap string? val))]
> [(#:bits) (or (equal? val 32) (equal? val 64))]
> - [(#:vc) (or (equal? val "x86") (equal? val "x64"))]
> + [(#:vc) (string? val)]
> [(#:sign-identity) (string? val)]
> [(#:timeout) (real? val)]
> [(#:j) (exact-positive-integer? val)]
>
> pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl
> +++ NEW/pkgs/racket-pkgs/racket-doc/scribblings/reference/filesystem.scrbl
> @@ -245,7 +245,7 @@ variations of the special filenames (e.g., @racket["LPT1"],
>
> @defproc[(link-exists? [path path-string?]) boolean?]{
>
> -Returns @racket[#t] if a link @racket[path] exists (@|AllUnix|),
> +Returns @racket[#t] if a link @racket[path] exists,
> @racket[#f] otherwise.
>
> The predicates @racket[file-exists?] or @racket[directory-exists?]
> @@ -255,7 +255,9 @@ work on the final destination of a link or series of links, while
> path).
>
> This procedure never raises the @racket[exn:fail:filesystem]
> -exception.}
> +exception.
> +
> + at history[#:changed "6.0.1.12" @elem{Added support for links on Windows.}]}
>
>
> @defproc[(delete-file [path path-string?]) void?]{
> @@ -393,12 +395,18 @@ rather than the link itself; if @racket[dest] refers to a link and
> @defproc[(make-file-or-directory-link [to path-string?] [path path-string?])
> void?]{
>
> -Creates a link @racket[path] to @racket[to] on @|AllUnix|. The
> +Creates a link @racket[path] to @racket[to]. The
> creation will fail if @racket[path] already exists. The @racket[to]
> need not refer to an existing file or directory, and @racket[to] is
> not expanded before writing the link. If the link is not created
> -successfully,the @exnraise[exn:fail:filesystem]. On Windows, the
> - at exnraise[exn:fail:unsupported] always.}
> +successfully,the @exnraise[exn:fail:filesystem].
> +
> +On Windows XP and earlier, the @exnraise[exn:fail:unsupported]. On
> +later versions of Windows, the creation of links tends to be
> +disallowed by security policies. Furthermore, a relative-path link is
> +parsed specially; see @secref["windowspaths"] for more information.
> +
> + at history[#:changed "6.0.1.12" @elem{Added support for links on Windows.}]}
>
> @;------------------------------------------------------------------------
> @section[#:tag "directories"]{Directories}
>
> pkgs/racket-pkgs/racket-doc/scribblings/reference/paths.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/racket-pkgs/racket-doc/scribblings/reference/paths.scrbl
> +++ NEW/pkgs/racket-pkgs/racket-doc/scribblings/reference/paths.scrbl
> @@ -345,11 +345,19 @@ This procedure does not access the filesystem.}
> @defproc[(resolve-path [path path-string?]) path?]{
>
> @tech{Cleanse}s @racket[path] and returns a path that references the
> -same file or directory as @racket[path]. On @|AllUnix|, if
> +same file or directory as @racket[path]. If
> @racket[path] is a soft link to another path, then the referenced path
> is returned (this may be a relative path with respect to the directory
> owning @racket[path]), otherwise @racket[path] is returned (after
> -expansion).}
> +expansion).
> +
> +On Windows, the path for a link should be simplified syntactically, so
> +that an up-directory indicator removes a preceding path element
> +independent of whether the preceding element itself refers to a
> +link. For relative-paths links, the path should be parsed specially;
> +see @secref["windowspaths"] for more information.
> +
> + at history[#:changed "6.0.1.12" @elem{Added support for links on Windows.}]}
>
>
> @defproc[(cleanse-path [path (or/c path-string? path-for-some-system?)])
> @@ -385,10 +393,12 @@ path. If @racket[path] syntactically refers to a directory, the
> result ends with a directory separator.
>
> When @racket[path] is simplified and @racket[use-filesystem?] is true
> -(the default), a complete path is returned; if @racket[path] is
> -relative, it is resolved with respect to the current directory, and
> -up-directory indicators are removed taking into account soft links (so
> -that the resulting path refers to the same directory as before).
> +(the default), a complete path is returned. If @racket[path] is
> +relative, it is resolved with respect to the current directory.
> +On @|AllUnix|, up-directory indicators are removed taking into account soft links (so
> +that the resulting path refers to the same directory as before);
> +on Windows, up-directory indicators are removed by by deleting a
> +preceding @tech{path element}.
>
> When @racket[use-filesystem?] is @racket[#f], up-directory indicators
> are removed by deleting a preceding @tech{path element}, and the result can
>
> pkgs/racket-pkgs/racket-doc/scribblings/reference/windows-paths.scrbl
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/racket-pkgs/racket-doc/scribblings/reference/windows-paths.scrbl
> +++ NEW/pkgs/racket-pkgs/racket-doc/scribblings/reference/windows-paths.scrbl
> @@ -234,6 +234,16 @@ directory. In addition, a path syntactically refers to a directory if
> its last element is a same-directory or up-directory indicator (not
> quoted by a @litchar{\\?\} form), or if it refers to a root.
>
> +Even on variants of Windows that support symbolic links, up-directory
> + at litchar{..} indicators in a path are resolved syntactically, not
> +sensitive to links. For example, if a path ends with @litchar{d\..\f}
> +and @litchar{d} refers to a symbolic link that references a directory
> +with a different parent than @litchar{d}, the path nevertheless refers
> +to @litchar{f} in the same directory as @litchar{d}. A relative-path
> +link is parsed as if prefixed with @litchar{\\?\REL} paths, except
> +that @litchar{..} and @litchar{.} elements are allowed throughout the
> +path, and any number of redundant @litchar{/} separators are allowed.
> +
> Windows paths are @techlink{cleanse}d as follows: In paths that start
> @litchar{\\?\}, redundant @litchar{\}s are removed, an extra
> @litchar{\} is added in a @litchar{\\?\REL} if an extra one is
>
> pkgs/racket-pkgs/racket-test/tests/racket/win-link.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- /dev/null
> +++ NEW/pkgs/racket-pkgs/racket-test/tests/racket/win-link.rkt
> @@ -0,0 +1,171 @@
> +#lang racket/base
> +(require racket/file)
> +
> +;; Run this test on a Windows machine with a user that is allowed
> +;; to create symbolic links. Since that's not usually the case,
> +;; `raco test` will do nothing:
> +(module test racket/base)
> +
> +(define count 0)
> +
> +(define-syntax-rule (test expect get)
> + (do-test expect get #'get))
> +(define (do-test expected got where)
> + (set! count (add1 count))
> + (unless (equal? expected got)
> + (error 'test
> + (string-append "failure\n"
> + " expected: ~e\n"
> + " got: ~e\n"
> + " expression: ~s")
> + expected
> + got
> + where)))
> +
> +(define temp-dir (find-system-path 'temp-dir))
> +
> +(define sub-name "link-sub")
> +(define sub (build-path temp-dir sub-name))
> +(delete-directory/files sub #:must-exist? #f)
> +(make-directory* sub)
> +
> +(define (go build tbuild rbuild)
> + (test #f (link-exists? (build "l1")))
> +
> + ;; t1 -> l1
> + (make-file-or-directory-link (rbuild "t1") (build "l1"))
> +
> + (test #t (link-exists? (build "l1")))
> + (test #f (file-exists? (build "l1")))
> + (test #f (directory-exists? (build "l1")))
> +
> + (make-directory (tbuild "t1"))
> + (test #t (link-exists? (build "l1")))
> + (test #f (file-exists? (build "l1")))
> + (test #t (directory-exists? (build "l1")))
> +
> + ;; File via link to enclsoing dir
> + (call-with-output-file (build-path (tbuild "t1") "f")
> + (lambda (o) (display "t1-f" o)))
> + (test (list (string->path "f")) (directory-list (build "l1")))
> + (test "t1-f" (file->string (build-path (build "l1") "f")))
> + (test #t (file-exists? (build-path (build "l1") "f")))
> + (test (file-or-directory-modify-seconds (build-path (tbuild "t1") "f"))
> + (file-or-directory-modify-seconds (build-path (build "l1") "f")))
> +
> + ;; Link to file in dir
> + (make-file-or-directory-link (let ([p (rbuild "t1")])
> + (if (path? p)
> + (build-path p "f2")
> + (string-append p "\\f2")))
> + (build "l2"))
> + (call-with-output-file (build-path (tbuild "t1") "f2")
> + (lambda (o) (display "t1-f2" o)))
> + (test "t1-f2" (file->string (build "l2")))
> + (delete-file (build-path (tbuild "t1") "f2"))
> +
> + ;; Link to dir in dir
> + (make-directory (build-path (tbuild "t1") "f2"))
> + (call-with-output-file (build-path (tbuild "t1") "f2" "f3")
> + (lambda (o) (display "t1-f2-f3" o)))
> + (test "t1-f2-f3" (file->string (build-path (build "l2") "f3")))
> + (test (list (string->path "f3")) (directory-list (build "l2")))
> + (delete-file (build "l2"))
> +
> + ;; Link to dir in dir with "." path elements
> + (make-file-or-directory-link (let ([p (rbuild "t1")])
> + (if (path? p)
> + (build-path p 'same 'same "f2" 'same)
> + (string-append p "\\.\\.\\f2\\.")))
> + (build "l2"))
> + (test #t (directory-exists? (build "l2")))
> + (test "t1-f2-f3" (file->string (build-path (build "l2") "f3")))
> + (test (list (string->path "f3")) (directory-list (build "l2")))
> + (delete-file (build "l2"))
> +
> + ;; Link with ".." to cancel first link element
> + (make-file-or-directory-link (let ([p (rbuild "t1")])
> + (if (path? p)
> + (build-path p 'up "f3")
> + (string-append p "\\..\\f3")))
> + (build "l3"))
> + (call-with-output-file (build-path (tbuild "t1") 'up "f3")
> + (lambda (o) (display "f3!" o)))
> + (test "f3!" (file->string (build "l3")))
> + (delete-file (build-path (tbuild "t1") 'up "f3"))
> + (delete-file (build "l3"))
> +
> + ;; Link with ".." to go up from link's directory
> + (make-file-or-directory-link (let ([p (rbuild "t1")])
> + (if (path? p)
> + (build-path p "f3")
> + (string-append "..\\" sub-name "\\" p "\\f3")))
> + (build "l3"))
> + (call-with-output-file (build-path (tbuild "t1") "f3")
> + (lambda (o) (display "f3." o)))
> + (test "f3." (file->string (build "l3")))
> + (delete-file (build-path (tbuild "t1") "f3"))
> + (delete-file (build "l3"))
> +
> + ;; Trailing ".."
> + (make-file-or-directory-link (let ([p (rbuild "t1")])
> + (if (path? p)
> + (build-path p 'up)
> + (string-append p "\\..")))
> + (build "l3"))
> + (call-with-output-file (build-path sub "f4")
> + (lambda (o) (display "(f4)" o)))
> + (test #t (directory-exists? (build "l3")))
> + (test "(f4)" (file->string (build-path (build "l3") "f4")))
> + (delete-file (build-path sub "f4"))
> + (delete-file (build "l3"))
> +
> + (delete-directory/files (tbuild "t1"))
> + (test #f (directory-exists? (build "l1")))
> + (test #f (file-exists? (build-path (build "l1") "f")))
> +
> + (call-with-output-file (tbuild "t1")
> + (lambda (o) (display "t1" o)))
> + (test "t1" (file->string (build "l1")))
> + (test #t (file-exists? (build "l1")))
> + (test (file-or-directory-modify-seconds (tbuild "t1"))
> + (file-or-directory-modify-seconds (build "l1")))
> +
> + (delete-file (tbuild "t1"))
> + (delete-file (build "l1")))
> +
> +(define (in-sub s) (build-path sub s))
> +(define (in-sub/unc s)
> + (define e (explode-path (in-sub s)))
> + (apply build-path
> + (format "\\\\localhost\\~a$\\"
> + (substring (path->string (car e)) 0 1))
> + (cdr e)))
> +(define (trailing-space/string s)
> + (string-append s " "))
> +(define (trailing-space s)
> + (string->path-element (trailing-space/string s)))
> +(define (trailing-space-in-sub s)
> + (in-sub (trailing-space s)))
> +(define (trailing-space-in-sub/unc s)
> + (define-values (base name dir) (split-path (in-sub/unc s)))
> + (build-path base (trailing-space s)))
> +
> +(go in-sub in-sub values)
> +(go in-sub in-sub in-sub)
> +(parameterize ([current-directory sub])
> + (go values values values)
> + (go values in-sub in-sub))
> +
> +(go in-sub/unc in-sub values)
> +(go in-sub in-sub in-sub/unc)
> +
> +(parameterize ([current-directory sub])
> + (go in-sub trailing-space trailing-space/string)
> + (go in-sub/unc trailing-space trailing-space/string))
> +(go in-sub trailing-space-in-sub trailing-space/string)
> +(go in-sub trailing-space-in-sub/unc trailing-space/string)
> +
> +(delete-directory/files sub)
> +
> +(printf "~a tests passed\n" count)
>
> pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt
> +++ NEW/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt
> @@ -2768,7 +2768,7 @@
> [assert (-poly (a b) (cl->*
> (Univ (make-pred-ty (list a) Univ b) . -> . b)
> (-> (Un a (-val #f)) a)))]
> -[defined? (->* (list Univ) -Boolean : (-FS (-not-filter -Undefined 0 null) (-filter -Undefined 0 null)))]
> +[defined? (->* (list Univ) -Boolean : (-FS (-not-filter -Undefined 0) (-filter -Undefined 0)))]
>
> ;; Syntax Manual
> ;; Section 2.1 (syntax/stx)
>
> racket/src/racket/sconfig.h
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/racket/src/racket/sconfig.h
> +++ NEW/racket/src/racket/sconfig.h
> @@ -562,12 +562,10 @@
> # if defined(_MSC_VER) || defined(__MINGW32__)
> # define NO_READDIR
> # define USE_FINDFIRST
> -# define NO_READLINK
> # define MKDIR_NO_MODE_FLAG
> # endif
> # if defined(__BORLANDC__)
> # define DIRENT_NO_NAMLEN
> -# define NO_READLINK
> # define MKDIR_NO_MODE_FLAG
> # endif
>
> @@ -852,46 +850,6 @@
>
> # endif
>
> - /************** DOS with Borland C++ ****************/
> - /* (Never successfully supported) */
> -
> -#if defined(__BORLANDC__) && defined(__MSDOS__)
> -
> -# define SCHEME_PLATFORM_LIBRARY_SUBPATH "dos\\i386"
> -
> -# define USE_SENORA_GC
> -# define DOS_FAR_POINTERS
> -# define SMALL_HASH_TABLES
> -
> -# define SYSTEM_TYPE_NAME "dos"
> -# define DOS_FILE_SYSTEM
> -# define USE_GETDISK
> -# define DIRENT_NO_NAMLEN
> -# define NO_READLINK
> -# define MKDIR_NO_MODE_FLAG
> -
> -# define TIME_SYNTAX
> -# define USE_FTIME
> -# define GETENV_FUNCTION
> -# define DIR_FUNCTION
> -
> -# define DO_STACK_CHECK
> -# define USE_STACKAVAIL
> -# define STACK_SAFETY_MARGIN 15000
> -
> -# define IGNORE_BY_CONTROL_87
> -
> -# define DIR_INCLUDE
> -# define IO_INCLUDE
> -# define NO_SLEEP
> -# define DONT_IGNORE_PIPE_SIGNAL
> -
> -# define REGISTER_POOR_MACHINE
> -
> -# define FLAGS_ALREADY_SET
> -
> -#endif
> -
> /************ QNX *************/
>
> #if defined(__QNX__)
> @@ -1079,8 +1037,6 @@
>
> /* NO_MKDIR means that there is no mkdir() function. */
>
> - /* NO_READLINK means that there is no readlink() function. */
> -
> /* BROKEN_READLINK_NUL_TERMINATOR means that readlink() may
> report a length that includes trailing NUL terminators,
> which should be stripped away. */
>
> racket/src/racket/src/file.c
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/racket/src/racket/src/file.c
> +++ NEW/racket/src/racket/src/file.c
> @@ -224,7 +224,8 @@ static int has_null(const char *s, intptr_t l);
> static void raise_null_error(const char *name, Scheme_Object *path, const char *mod);
>
> static char *do_path_to_complete_path(char *filename, intptr_t ilen, const char *wrt, intptr_t wlen, int kind);
> -static Scheme_Object *do_simplify_path(Scheme_Object *path, Scheme_Object *cycle_check, int skip, int use_filesystem, int force_rel_up, int kind);
> +static Scheme_Object *do_simplify_path(Scheme_Object *path, Scheme_Object *cycle_check, int skip, int use_filesystem,
> + int force_rel_up, int kind, int guards);
> static char *do_normal_path_seps(char *si, int *_len, int delta, int strip_trail, int kind, int *_did);
> static char *remove_redundant_slashes(char *filename, int *l, int delta, int *expanded, int kind);
> static Scheme_Object *do_path_to_directory_path(char *s, intptr_t offset, intptr_t len, Scheme_Object *p, int just_check, int kind);
> @@ -263,6 +264,16 @@ SHARED_OK static gid_t gid;
> SHARED_OK static gid_t egid;
> #endif
>
> +#ifdef DOS_FILE_SYSTEM
> +typedef BOOLEAN (WINAPI*CreateSymbolicLinkProc_t)(wchar_t *dest, wchar_t *src, DWORD flags);
> +static CreateSymbolicLinkProc_t CreateSymbolicLinkProc = NULL;
> +
> +typedef BOOL (WINAPI*DeviceIoControlProc_t)(HANDLE hDevice, DWORD dwIoControlCode, LPVOID lpInBuffer,
> + DWORD nInBufferSize, LPVOID lpOutBuffer, DWORD nOutBufferSize,
> + LPDWORD lpBytesReturned, LPOVERLAPPED lpOverlapped);
> +static DeviceIoControlProc_t DeviceIoControlProc;
> +#endif
> +
> void scheme_init_file(Scheme_Env *env)
> {
> Scheme_Object *p;
> @@ -586,6 +597,19 @@ void scheme_init_file(Scheme_Env *env)
> "use-collection-link-paths",
> MZCONFIG_USE_LINK_PATHS),
> env);
> +
> +#ifdef DOS_FILE_SYSTEM
> + {
> + HMODULE hm;
> + hm = LoadLibrary("kernel32.dll");
> +
> + CreateSymbolicLinkProc = (CreateSymbolicLinkProc_t)GetProcAddress(hm, "CreateSymbolicLinkW");
> + DeviceIoControlProc = (DeviceIoControlProc_t)GetProcAddress(hm, "DeviceIoControl");
> +
> + FreeLibrary(hm);
> + }
> +#endif
> +
> }
>
> void scheme_init_file_places()
> @@ -2045,7 +2069,7 @@ static char *do_expand_filename(Scheme_Object *o, char* filename, int ilen, cons
> Scheme_Object *p;
>
> p = scheme_make_sized_path(filename, ilen, 0);
> - p = do_simplify_path(p, scheme_null, 0, 1, 0, SCHEME_WINDOWS_PATH_KIND);
> + p = do_simplify_path(p, scheme_null, 0, 0, 0, SCHEME_WINDOWS_PATH_KIND, 0);
> filename = SCHEME_PATH_VAL(p);
> ilen = SCHEME_PATH_LEN(p);
>
> @@ -2083,6 +2107,7 @@ char *scheme_expand_string_filename(Scheme_Object *o, const char *errorin, int *
> # define FIND_FAILED(h) (h == INVALID_HANDLE_VALUE)
> # define FF_A_RDONLY FILE_ATTRIBUTE_READONLY
> # define FF_A_DIR FILE_ATTRIBUTE_DIRECTORY
> +# define FF_A_LINK 0x400
> # define GET_FF_ATTRIBS(fd) (fd.dwFileAttributes)
> # define GET_FF_MODDATE(fd) convert_date(&fd.ftLastWriteTime)
> # define GET_FF_NAME(fd) fd.cFileName
> @@ -2160,12 +2185,181 @@ static time_t convert_date(const FILETIME *ft)
> #endif
>
> #ifdef DOS_FILE_SYSTEM
> +
> +typedef struct mz_REPARSE_DATA_BUFFER {
> + ULONG ReparseTag;
> + USHORT ReparseDataLength;
> + USHORT Reserved;
> + union {
> + struct {
> + USHORT SubstituteNameOffset;
> + USHORT SubstituteNameLength;
> + USHORT PrintNameOffset;
> + USHORT PrintNameLength;
> + ULONG Flags;
> + WCHAR PathBuffer[1];
> + } SymbolicLinkReparseBuffer;
> + struct {
> + USHORT SubstituteNameOffset;
> + USHORT SubstituteNameLength;
> + USHORT PrintNameOffset;
> + USHORT PrintNameLength;
> + WCHAR PathBuffer[1];
> + } MountPointReparseBuffer;
> + struct {
> + UCHAR DataBuffer[1];
> + } GenericReparseBuffer;
> + } u;
> +} mz_REPARSE_DATA_BUFFER;
> +
> +#define mzFILE_FLAG_OPEN_REPARSE_POINT 0x200000
> +
> +static char *UNC_readlink(const char *fn)
> +{
> + HANDLE h;
> + DWORD got;
> + char *buffer;
> + int size = 1024;
> + mz_REPARSE_DATA_BUFFER *rp;
> + int len, off;
> + wchar_t *lk;
> +
> + if (!DeviceIoControlProc) return NULL;
> +
> + h = CreateFileW(WIDE_PATH(fn), GENERIC_READ,
> + FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, NULL,
> + OPEN_EXISTING, mzFILE_FLAG_OPEN_REPARSE_POINT,
> + NULL);
> +
> + if (h == INVALID_HANDLE_VALUE) {
> + errno = -1;
> + return NULL;
> + }
> +
> + while (1) {
> + buffer = (char *)scheme_malloc_atomic(size);
> + if (DeviceIoControlProc(h, FSCTL_GET_REPARSE_POINT, NULL, 0, buffer, size,
> + &got, NULL))
> + break;
> + else if (GetLastError() == ERROR_INSUFFICIENT_BUFFER) {
> + size *= 2;
> + buffer = (char *)scheme_malloc_atomic(size);
> + } else {
> + errno = -1;
> + CloseHandle(h);
> + return NULL;
> + }
> + }
> +
> + CloseHandle(h);
> +
> + rp = (mz_REPARSE_DATA_BUFFER *)buffer;
> + if (rp->ReparseTag != IO_REPARSE_TAG_SYMLINK) {
> + errno = -1;
> + return NULL;
> + }
> +
> + off = rp->u.SymbolicLinkReparseBuffer.PrintNameOffset;
> + len = rp->u.SymbolicLinkReparseBuffer.PrintNameLength;
> + lk = (wchar_t *)scheme_malloc_atomic(len + 2);
> +
> + memcpy(lk, (char *)rp->u.SymbolicLinkReparseBuffer.PathBuffer + off, len);
> + lk[len>>1] = 0;
> +
> + return NARROW_PATH(lk);
> +}
> +
> +Scheme_Object *combine_link_path(char *copy, int len, char *clink, int clen,
> + int ssq, int drive_end)
> +{
> + Scheme_Object *sp;
> +
> + /* Windows treats link paths purely syntactically (i.e., simplifying
> + "up" before consulting the filesystem). */
> +
> + if (scheme_is_relative_path(clink, clen, SCHEME_WINDOWS_PATH_KIND)) {
> + /* Windows treats absolute paths in the general way,
> + allowing forward slahses, stripping trailing spaces, and
> + so on. It treats relative paths as "\\?\REL\"-like, but
> + allowing ".." as up, "." as same, and multiple adjacent "\"s.
> + So, we implement yet another path construction (which is
> + likely what Windows itself does). */
> + int i;
> + char *copy2;
> + copy2 = (char *)scheme_malloc_atomic(len + clen + 10);
> + if (!ssq) {
> + /* Always use "\\?\" mode. */
> + if (copy[1] == ':') {
> + memcpy(copy2, "\\\\?\\", 4);
> + memcpy(copy2+4, copy, len);
> + len += 4;
> + drive_end += 4;
> + } else {
> + memcpy(copy2, "\\\\?\\UNC", 7);
> + memcpy(copy2+7, copy+1, len-1);
> + len += 6;
> + drive_end += 6;
> + }
> + ssq = 1;
> + } else
> + memcpy(copy2, copy, len);
> + copy = copy2;
> + i = -1; /* start with implicit ".." */
> + while (i < clen) {
> + if ((i < 0)
> + || ((i + 1 < clen)
> + && (clink[i] == '.') && (clink[i+1] == '.')
> + && ((i + 2 >= clen)
> + || (clink[i+2] == '\\')))) {
> + /* up directory; don't back over root */
> + if (len <= drive_end) {
> + errno = -1;
> + return 0;
> + }
> + while ((len > drive_end) && (copy[len-1] != '\\')) {
> + len--;
> + }
> + if ((len > drive_end) && (copy[len-1] == '\\')) {
> + len--;
> + }
> + if (i < 0)
> + i = 0;
> + else
> + i += 3;
> + } else if ((clink[i] == '.') && ((i + 1 >= clen)
> + || (clink[i+1] == '\\')))
> + i += 2; /* skip "." */
> + else if (clink[i] == '\\')
> + i++;
> + else {
> + if (copy[len-1] != '\\')
> + copy[len++] = '\\';
> + while ((i < clen) && (clink[i] != '\\')) {
> + copy[len++] = clink[i++];
> + }
> + }
> + }
> + copy[len] = 0;
> + sp = scheme_make_sized_path(copy, len, 0);
> + } else {
> + sp = scheme_make_sized_path(clink, clen, 0);
> + sp = do_simplify_path(sp, scheme_null, 0, 0, 0, SCHEME_WINDOWS_PATH_KIND, 0);
> + if (SCHEME_FALSEP(sp)) {
> + errno = -1;
> + return 0;
> + }
> + }
> +
> + return sp;
> +}
> +
> # define MZ_UNC_READ 0x1
> # define MZ_UNC_WRITE 0x2
> # define MZ_UNC_EXEC 0x4
>
> -static int UNC_stat(char *dirname, int len, int *flags, int *isdir, Scheme_Object **date,
> - mzlonglong *filesize, int set_flags)
> +static int UNC_stat(char *dirname, int len, int *flags, int *isdir, int *islink,
> + Scheme_Object **date, mzlonglong *filesize,
> + char **resolved_path, int set_flags)
> /* dirname must be absolute */
> {
> /* Note: stat() doesn't work with UNC "drive" names or \\?\ paths.
> @@ -2174,17 +2368,31 @@ static int UNC_stat(char *dirname, int len, int *flags, int *isdir, Scheme_Objec
> So, we use GetFileAttributesExW(). */
> char *copy;
> WIN32_FILE_ATTRIBUTE_DATA fd;
> - int must_be_dir = 0;
> + int must_be_dir = 0, drive_end, ssq;
> + Scheme_Object *cycle_check = scheme_null;
> +
> + if (resolved_path)
> + *resolved_path = NULL;
>
> + retry:
> +
> + if (islink)
> + *islink = 0;
> if (isdir)
> *isdir = 0;
> if (date)
> *date = scheme_false;
>
> copy = scheme_malloc_atomic(len + 14);
> - if (check_dos_slashslash_qm(dirname, len, NULL, NULL, NULL)) {
> + ssq = check_dos_slashslash_qm(dirname, len, &drive_end, NULL, NULL);
> + if (ssq) {
> memcpy(copy, dirname, len + 1);
> } else {
> + if (check_dos_slashslash_drive(dirname, 0, len, &drive_end, 0, 0))
> + drive_end++;
> + else
> + drive_end = 3; /* must be <letter>:/ */
> +
> memcpy(copy, dirname, len + 1);
> while (IS_A_DOS_SEP(copy[len - 1])) {
> --len;
> @@ -2192,24 +2400,62 @@ static int UNC_stat(char *dirname, int len, int *flags, int *isdir, Scheme_Objec
> must_be_dir = 1;
> }
> }
> - /* If we ended up with "\\?\X:", then drop the "\\?\" */
> +
> + /* If we ended up with "\\?\X:" (and nothing after), then drop the "\\?\" */
> if ((copy[0] == '\\')&& (copy[1] == '\\') && (copy[2] == '?') && (copy[3] == '\\')
> && is_drive_letter(copy[4]) && (copy[5] == ':') && !copy[6]) {
> memmove(copy, copy + 4, len - 4);
> len -= 4;
> + drive_end -= 4;
> copy[len] = 0;
> }
> - /* If we ended up with "\\?\X:", then drop the "\\?\\" */
> + /* If we ended up with "\\?\\X:" (and nothing after), then drop the "\\?\\" */
> if ((copy[0] == '\\') && (copy[1] == '\\') && (copy[2] == '?') && (copy[3] == '\\')
> && (copy[4] == '\\') && is_drive_letter(copy[5]) && (copy[6] == ':') && !copy[7]) {
> memmove(copy, copy + 5, len - 5);
> len -= 5;
> + drive_end -= 5;
> copy[len] = 0;
> }
> +
> if (!GetFileAttributesExW(WIDE_PATH(copy), GetFileExInfoStandard, &fd)) {
> errno = -1;
> return 0;
> } else {
> + if (GET_FF_ATTRIBS(fd) & FF_A_LINK) {
> + if (islink) {
> + *islink = 1;
> + return 1;
> + } else {
> + /* Resolve links ourselves. (We wouldn't have to do this at
> + all if GetFileAttributesEx() and FindFirstFile() provided a
> + way to follow links.) */
> + char *clink;
> + Scheme_Object *sp, *cl, *cp;
> + clink = UNC_readlink(dirname);
> + if (!clink) {
> + errno = -1;
> + return 0;
> + }
> + sp = combine_link_path(copy, len, clink, strlen(clink), ssq, drive_end);
> + for (cl = cycle_check; !SCHEME_NULLP(cl); cl = SCHEME_CDR(cl)) {
> + cp = SCHEME_CAR(cl);
> + if ((SCHEME_PATH_LEN(cp) == SCHEME_PATH_LEN(sp))
> + && !strcmp(SCHEME_PATH_VAL(cp), SCHEME_PATH_VAL(sp))) {
> + /* cycle */
> + errno = -1;
> + return 0;
> + }
> + }
> + cycle_check = scheme_make_pair(sp, cycle_check);
> + dirname = SCHEME_PATH_VAL(sp);
> + len = SCHEME_PATH_LEN(sp);
> + if (resolved_path)
> + *resolved_path = dirname;
> + goto retry;
> + }
> + }
> +
> if (set_flags != -1) {
> DWORD attrs = GET_FF_ATTRIBS(fd);
>
> @@ -2265,7 +2511,7 @@ int scheme_file_exists(char *filename)
>
> {
> int isdir;
> - return (UNC_stat(filename, strlen(filename), NULL, &isdir, NULL, NULL, -1)
> + return (UNC_stat(filename, strlen(filename), NULL, &isdir, NULL, NULL, NULL, NULL, -1)
> && !isdir);
> }
> # else
> @@ -2289,7 +2535,7 @@ int scheme_directory_exists(char *dirname)
> # ifdef DOS_FILE_SYSTEM
> int isdir;
>
> - return (UNC_stat(dirname, strlen(dirname), NULL, &isdir, NULL, NULL, -1)
> + return (UNC_stat(dirname, strlen(dirname), NULL, &isdir, NULL, NULL, NULL, NULL, -1)
> && isdir);
> # else
> struct MSC_IZE(stat) buf;
> @@ -2372,42 +2618,32 @@ static Scheme_Object *directory_exists(int argc, Scheme_Object **argv)
> static Scheme_Object *link_exists(int argc, Scheme_Object **argv)
> {
> char *filename;
> -#ifndef UNIX_FILE_SYSTEM
> - Scheme_Object *bs;
> -#endif
>
> if (!SCHEME_PATH_STRINGP(argv[0]))
> scheme_wrong_contract("link-exists?", "path-string?", 0, argc, argv);
>
> -
> -#ifndef UNIX_FILE_SYSTEM
> - /* DOS or MAC: expand isn't called, so check the form now */
> - bs = TO_PATH(argv[0]);
> - filename = SCHEME_PATH_VAL(bs);
> - if (has_null(filename, SCHEME_PATH_LEN(bs))) {
> - raise_null_error("link-exists?", bs, "");
> - return NULL;
> - }
> -#endif
> + filename = do_expand_filename(argv[0],
> + NULL,
> + 0,
> + "link-exists?",
> + NULL,
> + 0, 1,
> + SCHEME_GUARD_FILE_EXISTS,
> + SCHEME_PLATFORM_PATH_KIND,
> + 0);
>
> #ifdef DOS_FILE_SYSTEM
> - scheme_security_check_file("link-exists?", filename, SCHEME_GUARD_FILE_EXISTS);
> -
> - return scheme_false;
> -#endif
> -#ifdef UNIX_FILE_SYSTEM
> + {
> + int islink;
> + if (UNC_stat(filename, strlen(filename), NULL, NULL, &islink, NULL, NULL, NULL, -1)
> + && islink)
> + return scheme_true;
> + else
> + return scheme_false;
> + }
> +#else
> {
> struct MSC_IZE(stat) buf;
> -
> - filename = do_expand_filename(argv[0],
> - NULL,
> - 0,
> - "link-exists?",
> - NULL,
> - 0, 1,
> - SCHEME_GUARD_FILE_EXISTS,
> - SCHEME_PLATFORM_PATH_KIND,
> - 0);
> while (1) {
> if (!MSC_W_IZE(lstat)(MSC_WIDE_PATH(filename), &buf))
> break;
> @@ -2465,7 +2701,10 @@ Scheme_Object *scheme_get_fd_identity(Scheme_Object *port, intptr_t fd, char *pa
> FILE_SHARE_READ | FILE_SHARE_WRITE,
> NULL,
> OPEN_EXISTING,
> - FILE_FLAG_BACKUP_SEMANTICS,
> + FILE_FLAG_BACKUP_SEMANTICS
> + | ((fd && CreateSymbolicLinkProc)
> + ? mzFILE_FLAG_OPEN_REPARSE_POINT
> + : 0),
> NULL);
> if (fdh == INVALID_HANDLE_VALUE) {
> errid = GetLastError();
> @@ -2890,7 +3129,7 @@ static Scheme_Object *do_build_path(int argc, Scheme_Object **argv, int idelta,
> simp = do_simplify_path(scheme_make_sized_offset_kind_path(str, 0, pos, 0,
> SCHEME_WINDOWS_PATH_KIND),
> scheme_null, first_len, 0, 0,
> - SCHEME_WINDOWS_PATH_KIND);
> + SCHEME_WINDOWS_PATH_KIND, 0);
> if (SCHEME_FALSEP(simp)) {
> /* Base path is just relative "here". We can ignore it. */
> pos = 0;
> @@ -2953,7 +3192,7 @@ static Scheme_Object *do_build_path(int argc, Scheme_Object **argv, int idelta,
> simp = do_simplify_path(scheme_make_sized_offset_kind_path(str, 0, pos, 0,
> SCHEME_WINDOWS_PATH_KIND),
> scheme_null, first_len, 0, 1,
> - SCHEME_WINDOWS_PATH_KIND);
> + SCHEME_WINDOWS_PATH_KIND, 0);
> if (SCHEME_FALSEP(simp)) {
> /* Note: if root turns out to be relative, then we couldn't
> have had a \\?\RED\ path. */
> @@ -3245,7 +3484,7 @@ static Scheme_Object *do_build_path(int argc, Scheme_Object **argv, int idelta,
> str = do_normal_path_seps(str, &p, first_len, 1, SCHEME_WINDOWS_PATH_KIND, NULL);
> str = remove_redundant_slashes(str, &p, first_len, NULL, SCHEME_WINDOWS_PATH_KIND);
> simp = do_simplify_path(scheme_make_sized_offset_kind_path(str, 0, p, 0, SCHEME_WINDOWS_PATH_KIND),
> - scheme_null, first_len, 0, 1, SCHEME_WINDOWS_PATH_KIND);
> + scheme_null, first_len, 0, 1, SCHEME_WINDOWS_PATH_KIND, 0);
> if (SCHEME_FALSEP(simp))
> return scheme_make_sized_offset_kind_path(".\\", 0, 1, 0, SCHEME_WINDOWS_PATH_KIND);
> else
> @@ -4198,18 +4437,17 @@ static Scheme_Object *absolute_path_p(int argc, Scheme_Object **argv)
> : scheme_false);
> }
>
> -static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[])
> +static Scheme_Object *do_resolve_path(int argc, Scheme_Object *argv[], int guards)
> {
> -#ifndef NO_READLINK
> #define SL_NAME_MAX 2048
> char buffer[SL_NAME_MAX];
> -#endif
> -#ifndef NO_READLINK
> intptr_t len;
> int copied = 0;
> -#endif
> char *filename;
> int expanded;
> +#ifdef DOS_FILE_SYSTEM
> + int is_link;
> +#endif
>
> if (!SCHEME_PATH_STRINGP(argv[0]))
> scheme_wrong_contract("resolve-path", "path-string?", 0, argc, argv);
> @@ -4220,11 +4458,10 @@ static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[])
> "resolve-path",
> &expanded,
> 1, 0,
> - SCHEME_GUARD_FILE_EXISTS,
> + guards ? SCHEME_GUARD_FILE_EXISTS : 0,
> SCHEME_PLATFORM_PATH_KIND,
> 0);
>
> -#ifndef NO_READLINK
> {
> char *fullfilename = filename;
>
> @@ -4244,6 +4481,22 @@ static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[])
> fullfilename[--len] = 0;
> }
>
> +#ifdef DOS_FILE_SYSTEM
> + if (UNC_stat(fullfilename, len, NULL, NULL, &is_link, NULL, NULL, NULL, -1)
> + && is_link) {
> + const char *s;
> + s = UNC_readlink(fullfilename);
> + if (s) {
> + len = strlen(s);
> + if (len < SL_NAME_MAX)
> + memcpy(buffer, s, len+1);
> + else
> + len = -1;
> + } else
> + len = -1;
> + } else
> + len = -1;
> +#else
> while (1) {
> len = readlink(fullfilename, buffer, SL_NAME_MAX);
> if (len == -1) {
> @@ -4252,6 +4505,7 @@ static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[])
> } else
> break;
> }
> +#endif
>
> #ifdef BROKEN_READLINK_NUL_TERMINATOR
> while (len > 0 && buffer[len-1] == 0) {
> @@ -4262,7 +4516,6 @@ static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[])
> if (len > 0)
> return scheme_make_sized_path(buffer, len, 1);
> }
> -#endif
>
> if (!expanded)
> return argv[0];
> @@ -4270,6 +4523,11 @@ static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[])
> return scheme_make_sized_path(filename, strlen(filename), 1);
> }
>
> +static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[])
> +{
> + return do_resolve_path(argc, argv, 1);
> +}
> +
> static Scheme_Object *convert_literal_relative(Scheme_Object *file)
> {
> int ln;
> @@ -4453,7 +4711,7 @@ static Scheme_Object *simplify_qm_path(Scheme_Object *path)
> static Scheme_Object *do_simplify_path(Scheme_Object *path, Scheme_Object *cycle_check, int skip,
> int use_filesystem,
> int force_rel_up,
> - int kind)
> + int kind, int guards)
> /* When !use_filesystem, the result can be #f for an empty relative
> path, and it can contain leading ".."s, or ".."s after an initial
> "~" path with "~" paths are absolute.
> @@ -4632,7 +4890,7 @@ static Scheme_Object *do_simplify_path(Scheme_Object *path, Scheme_Object *cycle
> /* Make it absolute */
> s = scheme_expand_string_filename(path,
> "simplify-path", NULL,
> - SCHEME_GUARD_FILE_EXISTS);
> + guards ? SCHEME_GUARD_FILE_EXISTS : 0);
> len = strlen(s);
> }
>
> @@ -4711,13 +4969,13 @@ static Scheme_Object *do_simplify_path(Scheme_Object *path, Scheme_Object *cycle
> /* Build up path, watching for links just before a ..: */
> while (!SCHEME_NULLP(accum)) {
> if (SAME_OBJ(SCHEME_CAR(accum), up_symbol)) {
> - if (use_filesystem) {
> + if (use_filesystem && (SCHEME_PLATFORM_PATH_KIND != SCHEME_WINDOWS_PATH_KIND)) {
> /* Look for symlink in result-so-far. */
> Scheme_Object *new_result, *a[1];
>
> while (1) {
> a[0] = result;
> - new_result = resolve_path(1, a);
> + new_result = do_resolve_path(1, a, guards);
>
> /* Was it a link? */
> if (result != new_result) {
> @@ -4736,11 +4994,28 @@ static Scheme_Object *do_simplify_path(Scheme_Object *path, Scheme_Object *cycle
> aa[1] = new_result;
> new_result = do_build_path(2, aa, 0, 0, SCHEME_PLATFORM_PATH_KIND);
> }
> +
> + {
> + Scheme_Object *cl, *cp;
> + for (cl = cycle_check; !SCHEME_NULLP(cl); cl = SCHEME_CDR(cl)) {
> + cp = SCHEME_CAR(cl);
> + if ((SCHEME_PATH_LEN(cp) == SCHEME_PATH_LEN(new_result))
> + && !strcmp(SCHEME_PATH_VAL(cp), SCHEME_PATH_VAL(new_result))) {
> + /* cycle */
> + new_result = NULL;
> + break;
> + }
> + }
> + }
>
> - /* Simplify the new result */
> - result = do_simplify_path(new_result, cycle_check, skip,
> - use_filesystem, force_rel_up, kind);
> - cycle_check = scheme_make_pair(new_result, cycle_check);
> + if (new_result) {
> + /* Simplify the new result */
> + result = do_simplify_path(new_result, cycle_check, skip,
> + use_filesystem, force_rel_up, kind,
> + guards);
> + cycle_check = scheme_make_pair(new_result, cycle_check);
> + } else
> + break;
> } else
> break;
> }
> @@ -4843,7 +5118,7 @@ Scheme_Object *scheme_simplify_path(int argc, Scheme_Object *argv[])
> NULL);
> }
>
> - r = do_simplify_path(bs, scheme_null, 0, use_fs, 0, kind);
> + r = do_simplify_path(bs, scheme_null, 0, use_fs, 0, kind, 1);
>
> if (SCHEME_FALSEP(r)) {
> /* Input was just 'same: */
> @@ -4910,7 +5185,7 @@ static Scheme_Object *expand_user_path(int argc, Scheme_Object *argv[])
> "expand-user-path",
> &expanded,
> 1, 0,
> - SCHEME_GUARD_FILE_EXISTS,
> + SCHEME_GUARD_FILE_EXISTS,
> SCHEME_PLATFORM_PATH_KIND,
> 1);
>
> @@ -4971,7 +5246,7 @@ static Scheme_Object *do_directory_list(int break_ok, int argc, Scheme_Object *a
> if (SAME_OBJ(path, argv[0])) {
> Scheme_Object *old;
> old = scheme_make_path(filename);
> - path = do_simplify_path(old, scheme_null, 0, 1, 0, SCHEME_WINDOWS_PATH_KIND);
> + path = do_simplify_path(old, scheme_null, 0, 1, 0, SCHEME_WINDOWS_PATH_KIND, break_ok);
> if (SAME_OBJ(path, old))
> break;
> } else
> @@ -4988,6 +5263,8 @@ static Scheme_Object *do_directory_list(int break_ok, int argc, Scheme_Object *a
>
> # ifdef USE_FINDFIRST
>
> + retry:
> +
> if (!filename)
> pattern = "*.*";
> else {
> @@ -5029,15 +5306,27 @@ static Scheme_Object *do_directory_list(int break_ok, int argc, Scheme_Object *a
>
> hfile = FIND_FIRST(WIDE_PATH(pattern), &info);
> if (FIND_FAILED(hfile)) {
> + int err_val;
> if (!filename)
> return scheme_null;
> + err_val = GetLastError();
> + if ((err_val == ERROR_DIRECTORY) && CreateSymbolicLinkProc) {
> + /* check for symbolic link */
> + char *resolved;
> + if (UNC_stat(filename, strlen(filename), NULL, NULL, NULL, NULL, NULL, &resolved, -1)) {
> + if (resolved) {
> + filename = resolved;
> + goto retry;
> + }
> + }
> + }
> if (break_ok)
> scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
> "directory-list: could not open directory\n"
> " path: %q\n"
> " system error: %E",
> filename,
> - GetLastError());
> + err_val);
> return NULL;
> }
>
> @@ -5434,7 +5723,7 @@ static Scheme_Object *make_link(int argc, Scheme_Object *argv[])
> {
> char *src;
> Scheme_Object *dest;
> - int copied;
> + int copied, err_val;
>
> if (!SCHEME_PATH_STRINGP(argv[0]))
> scheme_wrong_contract("make-file-or-directory-link", "path-string?", 0, argc, argv);
> @@ -5459,11 +5748,26 @@ static Scheme_Object *make_link(int argc, Scheme_Object *argv[])
> SCHEME_PATH_VAL(dest));
>
> #if defined(DOS_FILE_SYSTEM)
> - scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
> - "make-file-or-directory-link: " NOT_SUPPORTED_STR ";\n"
> - " cannot create link\n"
> - " path: %Q",
> - argv[1]);
> + if (CreateSymbolicLinkProc) {
> + int flags;
> +
> + if (do_path_to_directory_path(src, 0, -1, argv[1], 1, SCHEME_WINDOWS_PATH_KIND))
> + flags = 0x1; /* directory */
> + else
> + flags = 0; /* file */
> +
> + if (CreateSymbolicLinkProc(WIDE_PATH_COPY(src),
> + WIDE_PATH_COPY(SCHEME_PATH_VAL(dest)),
> + flags))
> + return scheme_void;
> + err_val = GetLastError();
> + } else {
> + scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
> + "make-file-or-directory-link: " NOT_SUPPORTED_STR ";\n"
> + " cannot create link\n"
> + " path: %Q",
> + argv[1]);
> + }
> #else
> while (1) {
> if (!symlink(SCHEME_PATH_VAL(dest), src))
> @@ -5471,14 +5775,15 @@ static Scheme_Object *make_link(int argc, Scheme_Object *argv[])
> else if (errno != EINTR)
> break;
> }
> + err_val = errno;
> +#endif
>
> scheme_raise_exn((errno == EEXIST) ? MZEXN_FAIL_FILESYSTEM_EXISTS : MZEXN_FAIL_FILESYSTEM,
> "make-file-or-directory-link: cannot make link\n"
> " path: %q\n"
> - " system error: %e",
> + " system error: %E",
> filename_for_error(argv[1]),
> - errno);
> -#endif
> + err_val);
>
> return NULL;
> }
> @@ -5526,7 +5831,7 @@ static Scheme_Object *file_modify_seconds(int argc, Scheme_Object **argv)
> int len = strlen(file);
> Scheme_Object *secs;
>
> - if (UNC_stat(file, len, NULL, NULL, &secs, NULL, -1))
> + if (UNC_stat(file, len, NULL, NULL, NULL, &secs, NULL, NULL, -1))
> return secs;
> } else
> # endif
> @@ -5794,7 +6099,7 @@ static Scheme_Object *file_or_dir_permissions(int argc, Scheme_Object *argv[])
> } else
> new_bits = -1;
>
> - if (UNC_stat(filename, len, &flags, NULL, NULL, NULL, new_bits)) {
> + if (UNC_stat(filename, len, &flags, NULL, NULL, NULL, NULL, NULL, new_bits)) {
> if (set_bits)
> l = scheme_void;
> else if (as_bits)
> @@ -5819,7 +6124,7 @@ static Scheme_Object *file_or_dir_permissions(int argc, Scheme_Object *argv[])
> scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
> "file-or-directory-permissions: %s failed\n"
> " path: %q\n"
> - " system error: %e",
> + " system error: %E",
> set_bits ? "update" : "access",
> filename_for_error(argv[0]),
> err_val);
> @@ -5862,7 +6167,7 @@ static Scheme_Object *file_size(int argc, Scheme_Object *argv[])
>
> #ifdef DOS_FILE_SYSTEM
> {
> - if (UNC_stat(filename, strlen(filename), NULL, NULL, NULL, &len, -1)) {
> + if (UNC_stat(filename, strlen(filename), NULL, NULL, NULL, NULL, &len, NULL, -1)) {
> return scheme_make_integer_value_from_long_long(len);
> }
> }
> @@ -5911,7 +6216,7 @@ static Scheme_Object *cwd_check(int argc, Scheme_Object **argv)
> ed = scheme_make_sized_path(expanded, strlen(expanded), 1);
>
> # ifndef NO_FILE_SYSTEM_UTILS
> - ed = do_simplify_path(ed, scheme_null, 0, 1, 0, SCHEME_PLATFORM_PATH_KIND);
> + ed = do_simplify_path(ed, scheme_null, 0, 1, 0, SCHEME_PLATFORM_PATH_KIND, 1);
> # endif
>
> ed = scheme_path_to_directory_path(ed);
>
> racket/src/racket/src/jitarith.c
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/racket/src/racket/src/jitarith.c
> +++ NEW/racket/src/racket/src/jitarith.c
> @@ -681,7 +681,7 @@ static int generate_float_point_arith(mz_jit_state *jitter, Scheme_Object *rator
> } else {
> #ifdef MZ_LONG_DOUBLE
> long_double d;
> - d = long_double_from_int(second_const);
> + d = long_double_from_intptr(second_const);
> if (extfl) {
> mz_fpu_movi_ld_fppush(fpr1, d, JIT_R2)
> } else {
>
> racket/src/racket/src/longdouble/longdouble.c
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/racket/src/racket/src/longdouble/longdouble.c
> +++ NEW/racket/src/racket/src/longdouble/longdouble.c
> @@ -141,6 +141,7 @@ long_double get_long_double_half_pi()
> restore_mode(m);
> return result;
> }
> +
> long_double long_double_from_int(int a)
> {
> long_double result;
> @@ -150,7 +151,6 @@ long_double long_double_from_int(int a)
> return result;
> }
>
> -
> long_double long_double_from_float(float a)
> {
> long_double result;
> @@ -169,6 +169,15 @@ long_double long_double_from_double(double a)
> return result;
> }
>
> +long_double long_double_from_intptr(intptr_t a)
> +{
> + long_double result;
> + int m = ext_mode();
> + result.val = a;
> + restore_mode(m);
> + return result;
> +}
> +
> long_double long_double_from_uintptr(uintptr_t a)
> {
> long_double result;
> @@ -546,6 +555,7 @@ DECLARE_LDBL(void, set_long_double, (long_double a, long_double b))
> DECLARE_LDBL(long_double, long_double_from_int, (int a))
> DECLARE_LDBL(long_double, long_double_from_float, (float a))
> DECLARE_LDBL(long_double, long_double_from_double, (double a))
> +DECLARE_LDBL(long_double, long_double_from_intptr, (intptr_t a))
> DECLARE_LDBL(long_double, long_double_from_uintptr, (uintptr_t a))
> DECLARE_LDBL(double, double_from_long_double, (long_double a))
> DECLARE_LDBL(float, float_from_long_double, (long_double a))
> @@ -656,6 +666,7 @@ void scheme_load_long_double_dll()
> EXTRACT_LDBL(long_double_from_int, fail_long_double);
> EXTRACT_LDBL(long_double_from_float, fail_long_double);
> EXTRACT_LDBL(long_double_from_double, fail_long_double);
> + EXTRACT_LDBL(long_double_from_intptr, fail_long_double);
> EXTRACT_LDBL(long_double_from_uintptr, fail_long_double);
> EXTRACT_LDBL(double_from_long_double, fail_double);
> EXTRACT_LDBL(float_from_long_double, fail_float);
> @@ -729,6 +740,7 @@ void set_long_double(long_double a, long_double b) { _imp_set_long_double(a, b);
> long_double long_double_from_int(int a) { return _imp_long_double_from_int(a); }
> long_double long_double_from_float(float a) { return _imp_long_double_from_float(a); }
> long_double long_double_from_double(double a) { return _imp_long_double_from_double(a); }
> +long_double long_double_from_intptr(uintptr_t a) { return _imp_long_double_from_intptr(a); }
> long_double long_double_from_uintptr(uintptr_t a) { return _imp_long_double_from_uintptr(a); }
>
> double double_from_long_double(long_double a) { return _imp_double_from_long_double(a); }
>
> racket/src/racket/src/longdouble/longdouble.h
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/racket/src/racket/src/longdouble/longdouble.h
> +++ NEW/racket/src/racket/src/longdouble/longdouble.h
> @@ -57,6 +57,7 @@ XFORM_NONGCING LDBL_DLL_API void set_long_double(long_double a, long_double b);
> XFORM_NONGCING LDBL_DLL_API long_double long_double_from_int(int a);
> XFORM_NONGCING LDBL_DLL_API long_double long_double_from_float(float a);
> XFORM_NONGCING LDBL_DLL_API long_double long_double_from_double(double a);
> +XFORM_NONGCING LDBL_DLL_API long_double long_double_from_intptr(intptr_t a);
> XFORM_NONGCING LDBL_DLL_API long_double long_double_from_uintptr(uintptr_t a);
>
> XFORM_NONGCING LDBL_DLL_API double double_from_long_double(long_double a);
> @@ -142,6 +143,7 @@ XFORM_NONGCING int long_double_available();
> # define long_double_from_int(a) ((long double)(a))
> # define long_double_from_float(a) ((long double)(a))
> # define long_double_from_double(a) ((long double)(a))
> +# define long_double_from_intptr(a) ((long double)(a))
> # define long_double_from_uintptr(a) ((long double)(a))
>
> # define double_from_long_double(a) (a)
>
> racket/src/racket/src/number.c
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/racket/src/racket/src/number.c
> +++ NEW/racket/src/racket/src/number.c
> @@ -1814,7 +1814,7 @@ int scheme_long_minus_zero_p(long_double d)
> long_double scheme_real_to_long_double(Scheme_Object *r)
> {
> if (SCHEME_INTP(r))
> - return long_double_from_int(SCHEME_INT_VAL(r));
> + return long_double_from_intptr(SCHEME_INT_VAL(r));
> else if (SCHEME_DBLP(r))
> return long_double_from_double(SCHEME_DBL_VAL(r));
> else if (SCHEME_LONG_DBLP(r))
> @@ -3990,7 +3990,7 @@ static Scheme_Object *exact_to_extfl (int argc, Scheme_Object *argv[])
> Scheme_Type t;
>
> if (SCHEME_INTP(o))
> - return scheme_make_long_double(long_double_from_int(SCHEME_INT_VAL(o)));
> + return scheme_make_long_double(long_double_from_intptr(SCHEME_INT_VAL(o)));
>
> t = _SCHEME_TYPE(o);
> if (t == scheme_float_type)
> @@ -5118,7 +5118,7 @@ static Scheme_Object *fx_to_extfl (int argc, Scheme_Object *argv[])
> WHEN_LONG_DOUBLE_UNSUPPORTED(unsupported("fx->extfl"));
> if (!SCHEME_INTP(argv[0])) scheme_wrong_contract("fx->extfl", "fixnum?", 0, argc, argv);
> v = SCHEME_INT_VAL(argv[0]);
> - return scheme_make_long_double(long_double_from_int(v));
> + return scheme_make_long_double(long_double_from_intptr(v));
> #else
> return unsupported("fx->extfl");
> #endif
> @@ -5291,7 +5291,7 @@ static Scheme_Object *unsafe_fx_to_extfl (int argc, Scheme_Object *argv[])
> intptr_t v;
> if (scheme_current_thread->constant_folding) return exact_to_extfl(argc, argv);
> v = SCHEME_INT_VAL(argv[0]);
> - return scheme_make_long_double(long_double_from_int(v));
> + return scheme_make_long_double(long_double_from_intptr(v));
> #else
> return fx_to_extfl(argc, argv);
> #endif
>
> racket/src/racket/src/optimize.c
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/racket/src/racket/src/optimize.c
> +++ NEW/racket/src/racket/src/optimize.c
> @@ -3447,7 +3447,7 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info, int
> inside = t2;
> t2 = ((Scheme_Compiled_Let_Value *)t2)->body;
> }
> - } if (SAME_TYPE(SCHEME_TYPE(t2), scheme_sequence_type)) {
> + } else if (SAME_TYPE(SCHEME_TYPE(t2), scheme_sequence_type)) {
> Scheme_Sequence *seq = (Scheme_Sequence *)t2;
> if (seq->count) {
> inside = t2;
>
> racket/src/racket/src/ratfloat.inc
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/racket/src/racket/src/ratfloat.inc
> +++ NEW/racket/src/racket/src/ratfloat.inc
> @@ -31,7 +31,7 @@ FP_TYPE SCHEME_RATIONAL_TO_FLOAT(const Scheme_Object *o)
> #ifdef CONVERT_INT_TO_FLOAT
> n = CONVERT_INT_TO_FLOAT(SCHEME_INT_VAL(r->num));
> #else
> - n = FP_TYPE_FROM_INT(SCHEME_INT_VAL(r->num));
> + n = FP_TYPE_FROM_INTPTR(SCHEME_INT_VAL(r->num));
> #endif
> ns = 0;
> } else {
> @@ -49,7 +49,7 @@ FP_TYPE SCHEME_RATIONAL_TO_FLOAT(const Scheme_Object *o)
>
> if (SCHEME_INTP(r->denom)) {
> if (FIXNUM_FITS_FP(r->denom)) {
> - d = FP_TYPE_FROM_INT(SCHEME_INT_VAL(r->denom));
> + d = FP_TYPE_FROM_INTPTR(SCHEME_INT_VAL(r->denom));
> ds = 0;
> } else {
> d = FP_ZEROx;
> @@ -130,11 +130,11 @@ FP_TYPE SCHEME_RATIONAL_TO_FLOAT(const Scheme_Object *o)
> }
>
> if (SCHEME_INTP(n))
> - res = FP_TYPE_FROM_INT(SCHEME_INT_VAL(n));
> + res = FP_TYPE_FROM_INTPTR(SCHEME_INT_VAL(n));
> else
> res = SCHEME_BIGNUM_TO_FLOAT_INF_INFO(n, 0, NULL);
>
> - res = FP_MULT(res, FP_TYPE_FROM_INT(FP_POWx(2, p - shift)));
> + res = FP_MULT(res, FP_POWx(FP_TYPE_FROM_INT(2), FP_TYPE_FROM_INTPTR(p - shift)));
>
> if (SCHEME_INTP(r->num)) {
> if (SCHEME_INT_VAL(r->num) < 0)
> @@ -291,6 +291,7 @@ Scheme_Object *SCHEME_RATIONAL_FROM_FLOAT(FP_TYPE d)
> #undef FP_DIV
> #undef FP_NEG
> #undef FP_LESS
> +#undef FP_TYPE_FROM_INTPTR
> #undef FP_TYPE_FROM_INT
> #undef FP_LDEXP
> #undef FP_EQV
>
> racket/src/racket/src/rational.c
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/racket/src/racket/src/rational.c
> +++ NEW/racket/src/racket/src/rational.c
> @@ -526,7 +526,8 @@ Scheme_Object *scheme_rational_sqrt(const Scheme_Object *o)
> #define FP_EQV(x,y) x==y
> #define FP_LESS(x, y) x<y
> #define FP_IS_ZERO(x) x==0.0
> -#define FP_TYPE_FROM_INT(x) (FP_TYPE)x
> +#define FP_TYPE_FROM_INT(x) ((FP_TYPE)(x))
> +#define FP_TYPE_FROM_INTPTR(x) ((FP_TYPE)(x))
> #ifdef SIXTY_FOUR_BIT_INTEGERS
> # define FIXNUM_FITS_FP(x) (!(SCHEME_INT_VAL(x) & ~(((intptr_t)1 << (FLOAT_M_BITS-1)) - 1)))
> # define BIGNUM_FITS_FP(x) 0
> @@ -553,7 +554,8 @@ Scheme_Object *scheme_rational_sqrt(const Scheme_Object *o)
> #define FP_NEG(x) -x
> #define FP_EQV(x,y) x==y
> #define FP_LESS(x, y) x<y
> -#define FP_TYPE_FROM_INT(x) (FP_TYPE)x
> +#define FP_TYPE_FROM_INT(x) ((FP_TYPE)(x))
> +#define FP_TYPE_FROM_INTPTR(x) ((FP_TYPE)(x))
> #define FIXNUM_FITS_FP(x) (!(SCHEME_INT_VAL(x) & ~(((intptr_t)1 << (FLOAT_M_BITS-1)) - 1)))
> #define FP_IS_ZERO(x) x==0.0
> #define BIGNUM_FITS_FP(x) 0
> @@ -581,6 +583,7 @@ Scheme_Object *scheme_rational_sqrt(const Scheme_Object *o)
> # define FP_EQV(x,y) long_double_eqv(x,y)
> # define FP_LESS(x, y) long_double_less(x,y)
> # define FP_TYPE_FROM_INT(x) long_double_from_int(x)
> +# define FP_TYPE_FROM_INTPTR(x) long_double_from_intptr(x)
> # define FIXNUM_FITS_FP(x) 1
> # define BIGNUM_FITS_FP(x) (scheme_integer_length(x) <= (FLOAT_M_BITS-1))
> # define FP_IS_ZERO(x) long_double_is_zero(x)
> @@ -593,7 +596,7 @@ Scheme_Object *scheme_rational_sqrt(const Scheme_Object *o)
> # define FLOAT_M_BITS 64
> # define FLOAT_E_BITS 15
> # define FP_ZEROx get_long_double_zero()
> -# define FP_POWx pow
> +# define FP_POWx long_double_pow
> # define FP_MODFx long_double_modf
> # define FP_FREXPx long_double_frexp
> # define FP_LDEXP long_double_ldexp
>
> racket/src/worksp/.gitignore
> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
> --- OLD/racket/src/worksp/.gitignore
> +++ NEW/racket/src/worksp/.gitignore
> @@ -11,6 +11,7 @@
> */*.ncb
> */*.suo
> */*.sdf
> +*/*.sln.cache
>
> checkvs9.obj
> checkvs9.exe
![[logo]](/logo.png){kind=logo}