Back to index

plt-scheme  4.2.1
file.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 1995-2001 Matthew Flatt
00005 
00006     This library is free software; you can redistribute it and/or
00007     modify it under the terms of the GNU Library General Public
00008     License as published by the Free Software Foundation; either
00009     version 2 of the License, or (at your option) any later version.
00010 
00011     This library is distributed in the hope that it will be useful,
00012     but WITHOUT ANY WARRANTY; without even the implied warranty of
00013     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00014     Library General Public License for more details.
00015 
00016     You should have received a copy of the GNU Library General Public
00017     License along with this library; if not, write to the Free
00018     Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
00019     Boston, MA 02110-1301 USA.
00020 
00021   libscheme
00022   Copyright (c) 1994 Brent Benson
00023   All rights reserved.
00024 */
00025 
00026 /* Most of this source file is pathname manipulation functions.  At
00027    the bottom, a path is just a byte string, not necessarily
00028    normalized in any way, except that it doesn't contain a nul
00029    character. The advantage of this representation is that it keeps
00030    paths the way the user wrote them. The tremendous disadvantage of
00031    this representation is that all of the operations must manipulate
00032    strings.
00033 
00034    A major complication is the complex syntax of Windows paths. Again,
00035    since all the operations work on the string, the code in this file
00036    parses and re-parses constantly.
00037 
00038  */
00039 
00040 #include "schpriv.h"
00041 #ifdef UNISTD_INCLUDE
00042 # include <unistd.h>
00043 #endif
00044 #ifndef NO_STAT_PROC
00045 # ifdef NO_SYS_INCLUDE_SUBDIR
00046 #  include <stat.h>
00047 # else
00048 #  include <sys/types.h>
00049 #  include <sys/stat.h>
00050 # endif
00051 #endif
00052 #ifdef EXPAND_FILENAME_TILDE
00053 # include <pwd.h>
00054 #endif
00055 #ifndef NO_FILE_SYSTEM_UTILS
00056 # include <ctype.h>
00057 # ifndef NO_READDIR
00058 #  include <dirent.h>
00059 # endif
00060 #endif
00061 #ifdef DIR_INCLUDE
00062 # include <dir.h>
00063 #endif
00064 #ifdef DIRECT_INCLUDE
00065 # include <direct.h>
00066 #endif
00067 #ifdef IO_INCLUDE
00068 # include <io.h>
00069 #endif
00070 #if defined(MACINTOSH_EVENTS)
00071 # ifdef OS_X
00072 #  include <Carbon/Carbon.h>
00073 # else
00074 #  include <Carbon.h>
00075 # endif
00076 #endif
00077 #ifdef UNIX_FILE_SYSTEM
00078 # include <fcntl.h>
00079 # include <grp.h>
00080 # include <pwd.h>
00081 # include <utime.h>
00082 #endif
00083 #ifdef DOS_FILE_SYSTEM
00084 # include <windows.h>
00085 # include <shlobj.h>
00086 # ifdef __BORLANDC__
00087 #  include <utime.h>
00088 # else
00089 #  include <sys/utime.h>
00090 # endif
00091 #endif
00092 #ifdef NO_ERRNO_GLOBAL
00093 # define errno -1
00094 #else
00095 # include <errno.h>
00096 #endif
00097 
00098 #if defined(S_IFDIR) && !defined(S_ISDIR)
00099 # define S_ISDIR(m) ((m) & S_IFDIR)
00100 #endif
00101 #if defined(S_IFREG) && !defined(S_ISREG)
00102 # define S_ISREG(m) ((m) & S_IFREG)
00103 #endif
00104 #if defined(S_IFLNK) && !defined(S_ISLNK)
00105 # define S_ISLNK(m) ((m) & S_IFLNK)
00106 #endif
00107 #if defined(_S_IFDIR) && !defined(S_ISDIR)
00108 # define S_ISDIR(m) ((m) & _S_IFDIR)
00109 #endif
00110 #if defined(_S_IFREG) && !defined(S_ISREG)
00111 # define S_ISREG(m) ((m) & _S_IFREG)
00112 #endif
00113 
00114 #if defined(CARBON_FILE_SYSTEM)
00115 long scheme_creator_id = 'MzSc';
00116 #endif
00117 
00118 #define UNIX_FN_SEP '/'
00119 #define IS_A_UNIX_SEP(x) ((x) == '/')
00120 #define IS_A_UNIX_PRIM_SEP(x) IS_A_UNIX_SEP(x)
00121 
00122 #define DOS_FN_SEP '\\'
00123 #define IS_A_DOS_SEP(x) (((x) == '/') || ((x) == '\\'))
00124 #define IS_A_DOS_PRIM_SEP(x) ((x) == '\\')
00125 #define IS_A_DOS_X_SEP(prim, x) (prim ? IS_A_DOS_PRIM_SEP(x) : IS_A_DOS_SEP(x))
00126 
00127 #define FN_SEP(kind) ((kind == SCHEME_UNIX_PATH_KIND) ? UNIX_FN_SEP : DOS_FN_SEP)
00128 #define IS_A_SEP(kind, x) ((kind == SCHEME_UNIX_PATH_KIND) ? IS_A_UNIX_SEP(x) : IS_A_DOS_SEP(x))
00129 #define IS_A_PRIM_SEP(kind, x) ((kind == SCHEME_UNIX_PATH_KIND) ? IS_A_UNIX_PRIM_SEP(x) : IS_A_DOS_PRIM_SEP(x))
00130 
00131 MZ_DLLSPEC int scheme_ignore_user_paths;
00132 void scheme_set_ignore_user_paths(int v) { scheme_ignore_user_paths = v; }
00133 
00134 #define CURRENT_WD() scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_DIRECTORY)
00135 
00136 #define TO_PATH(x) (SCHEME_GENERAL_PATHP(x) ? x : scheme_char_string_to_path(x))
00137 
00138 #ifdef DOS_FILE_SYSTEM
00139 extern int scheme_stupid_windows_machine;
00140 #endif
00141 
00142 /* Define TILDE_IS_ABSOLUTE to get pre-v4.0 handling of "~". */
00143 
00144 #ifdef TILDE_IS_ABSOLUTE
00145 # define WHEN_TILDE_IS_ABSOLUTE(x) (x)
00146 #else
00147 # define WHEN_TILDE_IS_ABSOLUTE(x) 0
00148 #endif
00149 
00150 static int check_dos_slashslash_drive(const char *next, int delta, int len, 
00151                                   int *drive_end, int exact, int no_fw);
00152 static int check_dos_slashslash_qm(const char *next, int len, int *drive_end, 
00153                                int *clean_start, int *add_sep);
00154 
00155 #define is_drive_letter(c) (((unsigned char)c < 128) && isalpha((unsigned char)c))
00156 
00157 /* local */
00158 static Scheme_Object *path_p(int argc, Scheme_Object **argv);
00159 static Scheme_Object *general_path_p(int argc, Scheme_Object **argv);
00160 static Scheme_Object *path_to_string(int argc, Scheme_Object **argv);
00161 static Scheme_Object *path_to_bytes(int argc, Scheme_Object **argv);
00162 static Scheme_Object *path_element_to_bytes(int argc, Scheme_Object **argv);
00163 static Scheme_Object *path_element_to_string(int argc, Scheme_Object **argv);
00164 static Scheme_Object *string_to_path(int argc, Scheme_Object **argv);
00165 static Scheme_Object *bytes_to_path(int argc, Scheme_Object **argv);
00166 static Scheme_Object *bytes_to_path_element(int argc, Scheme_Object **argv);
00167 static Scheme_Object *string_to_path_element(int argc, Scheme_Object **argv);
00168 static Scheme_Object *path_kind(int argc, Scheme_Object **argv);
00169 static Scheme_Object *platform_path_kind(int argc, Scheme_Object **argv);
00170 
00171 static Scheme_Object *file_exists(int argc, Scheme_Object **argv);
00172 static Scheme_Object *directory_exists(int argc, Scheme_Object **argv);
00173 static Scheme_Object *link_exists(int argc, Scheme_Object **argv);
00174 
00175 #ifndef NO_FILE_SYSTEM_UTILS
00176 static Scheme_Object *build_path_kind(int argc, Scheme_Object **argv);
00177 static Scheme_Object *delete_file(int argc, Scheme_Object **argv);
00178 static Scheme_Object *rename_file(int argc, Scheme_Object **argv);
00179 static Scheme_Object *copy_file(int argc, Scheme_Object **argv);
00180 static Scheme_Object *path_to_directory_path(int argc, Scheme_Object *argv[]);
00181 static Scheme_Object *directory_list(int argc, Scheme_Object *argv[]);
00182 static Scheme_Object *filesystem_root_list(int argc, Scheme_Object *argv[]);
00183 static Scheme_Object *make_directory(int argc, Scheme_Object *argv[]);
00184 static Scheme_Object *delete_directory(int argc, Scheme_Object *argv[]);
00185 static Scheme_Object *make_link(int argc, Scheme_Object *argv[]);
00186 static Scheme_Object *split_path(int argc, Scheme_Object **argv);
00187 static Scheme_Object *relative_path_p(int argc, Scheme_Object **argv);
00188 static Scheme_Object *absolute_path_p(int argc, Scheme_Object **argv);
00189 static Scheme_Object *complete_path_p(int argc, Scheme_Object **argv);
00190 static Scheme_Object *path_to_complete_path(int argc, Scheme_Object **argv);
00191 static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[]);
00192 static Scheme_Object *simplify_path(int argc, Scheme_Object *argv[]);
00193 static Scheme_Object *cleanse_path(int argc, Scheme_Object *argv[]);
00194 static Scheme_Object *expand_user_path(int argc, Scheme_Object *argv[]);
00195 static Scheme_Object *current_drive(int argc, Scheme_Object *argv[]);
00196 static Scheme_Object *file_modify_seconds(int argc, Scheme_Object *argv[]);
00197 static Scheme_Object *file_or_dir_permissions(int argc, Scheme_Object *argv[]);
00198 static Scheme_Object *file_size(int argc, Scheme_Object *argv[]);
00199 static Scheme_Object *current_library_collection_paths(int argc, Scheme_Object *argv[]);
00200 static Scheme_Object *use_compiled_kind(int, Scheme_Object *[]);
00201 static Scheme_Object *use_user_paths(int, Scheme_Object *[]);
00202 static Scheme_Object *find_system_path(int argc, Scheme_Object **argv);
00203 #endif
00204 
00205 #ifdef DIR_FUNCTION
00206 static Scheme_Object *current_directory(int argc, Scheme_Object *argv[]);
00207 #endif
00208 
00209 static int has_null(const char *s, long l);
00210 static void raise_null_error(const char *name, Scheme_Object *path, const char *mod);
00211 
00212 static char *do_path_to_complete_path(char *filename, long ilen, const char *wrt, long wlen, int kind);
00213 static Scheme_Object *do_simplify_path(Scheme_Object *path, Scheme_Object *cycle_check, int skip, int use_filesystem, int force_rel_up, int kind);
00214 static char *do_normal_path_seps(char *si, int *_len, int delta, int strip_trail, int kind, int *_did);
00215 static char *remove_redundant_slashes(char *filename, int *l, int delta, int *expanded, int kind);
00216 static Scheme_Object *do_path_to_directory_path(char *s, long offset, long len, Scheme_Object *p, int just_check, int kind);
00217 
00218 static Scheme_Object *up_symbol, *relative_symbol;
00219 static Scheme_Object *same_symbol;
00220 #ifndef NO_FILE_SYSTEM_UTILS
00221 static Scheme_Object *read_symbol, *write_symbol, *execute_symbol;
00222 
00223 static Scheme_Object *temp_dir_symbol, *home_dir_symbol, *pref_dir_symbol;
00224 static Scheme_Object *doc_dir_symbol, *desk_dir_symbol;
00225 static Scheme_Object *init_dir_symbol, *init_file_symbol, *sys_dir_symbol;
00226 static Scheme_Object *exec_file_symbol, *run_file_symbol, *collects_dir_symbol;
00227 static Scheme_Object *pref_file_symbol, *orig_dir_symbol, *addon_dir_symbol;
00228 
00229 static Scheme_Object *exec_cmd, *run_cmd, *collects_path, *original_pwd;
00230 #endif
00231 static Scheme_Object *windows_symbol, *unix_symbol;
00232 
00233 void scheme_init_file(Scheme_Env *env)
00234 {
00235   REGISTER_SO(up_symbol);
00236   REGISTER_SO(relative_symbol);
00237   REGISTER_SO(same_symbol);
00238 #ifndef NO_FILE_SYSTEM_UTILS
00239   REGISTER_SO(read_symbol);
00240   REGISTER_SO(write_symbol);
00241   REGISTER_SO(execute_symbol);
00242   
00243   REGISTER_SO(temp_dir_symbol);
00244   REGISTER_SO(home_dir_symbol);
00245   REGISTER_SO(pref_dir_symbol);
00246   REGISTER_SO(doc_dir_symbol);
00247   REGISTER_SO(desk_dir_symbol);
00248   REGISTER_SO(init_dir_symbol);
00249   REGISTER_SO(init_file_symbol);
00250   REGISTER_SO(sys_dir_symbol);
00251   REGISTER_SO(pref_file_symbol);
00252   REGISTER_SO(exec_file_symbol);
00253   REGISTER_SO(run_file_symbol);
00254   REGISTER_SO(collects_dir_symbol);
00255   REGISTER_SO(orig_dir_symbol);
00256   REGISTER_SO(addon_dir_symbol);
00257 #endif
00258   REGISTER_SO(windows_symbol);
00259   REGISTER_SO(unix_symbol);
00260 
00261   up_symbol = scheme_intern_symbol("up");
00262   relative_symbol = scheme_intern_symbol("relative");
00263   same_symbol = scheme_intern_symbol("same");
00264   
00265 #ifndef NO_FILE_SYSTEM_UTILS
00266   read_symbol = scheme_intern_symbol("read");
00267   write_symbol = scheme_intern_symbol("write");
00268   execute_symbol = scheme_intern_symbol("execute");
00269   
00270   temp_dir_symbol = scheme_intern_symbol("temp-dir");
00271   home_dir_symbol = scheme_intern_symbol("home-dir");
00272   doc_dir_symbol = scheme_intern_symbol("doc-dir");
00273   desk_dir_symbol = scheme_intern_symbol("desk-dir");
00274   pref_dir_symbol = scheme_intern_symbol("pref-dir");
00275   init_dir_symbol = scheme_intern_symbol("init-dir");
00276   init_file_symbol = scheme_intern_symbol("init-file");
00277   sys_dir_symbol = scheme_intern_symbol("sys-dir");
00278   pref_file_symbol = scheme_intern_symbol("pref-file");
00279   exec_file_symbol = scheme_intern_symbol("exec-file");
00280   run_file_symbol = scheme_intern_symbol("run-file");
00281   collects_dir_symbol = scheme_intern_symbol("collects-dir");
00282   orig_dir_symbol = scheme_intern_symbol("orig-dir");
00283   addon_dir_symbol = scheme_intern_symbol("addon-dir");
00284 #endif
00285 
00286   windows_symbol = scheme_intern_symbol("windows");
00287   unix_symbol = scheme_intern_symbol("unix");
00288 
00289   scheme_add_global_constant("path?", 
00290                           scheme_make_prim_w_arity(path_p, 
00291                                                 "path?", 
00292                                                 1, 1), 
00293                           env);
00294   scheme_add_global_constant("path-for-some-system?", 
00295                           scheme_make_folding_prim(general_path_p, 
00296                                                       "path-for-some-system?", 
00297                                                       1, 1, 1), 
00298                           env);
00299   scheme_add_global_constant("path-convention-type", 
00300                           scheme_make_folding_prim(path_kind, 
00301                                                       "path-convention-type", 
00302                                                       1, 1, 1), 
00303                           env);
00304   scheme_add_global_constant("system-path-convention-type", 
00305                           scheme_make_prim_w_arity(platform_path_kind, 
00306                                                       "system-path-convention-type", 
00307                                                       0, 0),
00308                           env);
00309   scheme_add_global_constant("path->string", 
00310                           scheme_make_prim_w_arity(path_to_string, 
00311                                                 "path->string", 
00312                                                 1, 1), 
00313                           env);
00314   scheme_add_global_constant("path->bytes", 
00315                           scheme_make_prim_w_arity(path_to_bytes, 
00316                                                 "path->bytes", 
00317                                                 1, 1), 
00318                           env);
00319   scheme_add_global_constant("path-element->bytes", 
00320                           scheme_make_prim_w_arity(path_element_to_bytes, 
00321                                                 "path-element->bytes", 
00322                                                 1, 1), 
00323                           env);
00324   scheme_add_global_constant("path-element->string", 
00325                           scheme_make_prim_w_arity(path_element_to_string, 
00326                                                 "path-element->string", 
00327                                                 1, 1), 
00328                           env);
00329   scheme_add_global_constant("string->path", 
00330                           scheme_make_prim_w_arity(string_to_path, 
00331                                                 "string->path", 
00332                                                 1, 1), 
00333                           env);
00334   scheme_add_global_constant("bytes->path", 
00335                           scheme_make_prim_w_arity(bytes_to_path, 
00336                                                 "bytes->path", 
00337                                                 1, 2), 
00338                           env);
00339   scheme_add_global_constant("bytes->path-element", 
00340                           scheme_make_prim_w_arity(bytes_to_path_element, 
00341                                                 "bytes->path-element", 
00342                                                 1, 2), 
00343                           env);
00344   scheme_add_global_constant("string->path-element", 
00345                           scheme_make_prim_w_arity(string_to_path_element, 
00346                                                 "string->path-element", 
00347                                                 1, 1), 
00348                           env);
00349 
00350   scheme_add_global_constant("file-exists?", 
00351                           scheme_make_prim_w_arity(file_exists, 
00352                                                 "file-exists?", 
00353                                                 1, 1), 
00354                           env);
00355   scheme_add_global_constant("directory-exists?", 
00356                           scheme_make_prim_w_arity(directory_exists, 
00357                                                 "directory-exists?", 
00358                                                 1, 1), 
00359                           env);
00360   scheme_add_global_constant("link-exists?", 
00361                           scheme_make_prim_w_arity(link_exists, 
00362                                                 "link-exists?", 
00363                                                 1, 1), 
00364                           env);
00365 #ifndef NO_FILE_SYSTEM_UTILS
00366   scheme_add_global_constant("delete-file", 
00367                           scheme_make_prim_w_arity(delete_file, 
00368                                                 "delete-file", 
00369                                                 1, 1), 
00370                           env);
00371   scheme_add_global_constant("rename-file-or-directory", 
00372                           scheme_make_prim_w_arity(rename_file, 
00373                                                 "rename-file-or-directory", 
00374                                                 2, 3), 
00375                           env);
00376   scheme_add_global_constant("copy-file", 
00377                           scheme_make_prim_w_arity(copy_file, 
00378                                                 "copy-file", 
00379                                                 2, 2), 
00380                           env);
00381   scheme_add_global_constant("build-path", 
00382                           scheme_make_prim_w_arity(scheme_build_path,
00383                                                 "build-path", 
00384                                                 1, -1), 
00385                           env);
00386   scheme_add_global_constant("build-path/convention-type", 
00387                           scheme_make_prim_w_arity(build_path_kind,
00388                                                 "build-path/convention-type", 
00389                                                 2, -1), 
00390                           env);
00391   scheme_add_global_constant("path->directory-path",
00392                           scheme_make_prim_w_arity(path_to_directory_path,
00393                                                 "path->directory-path",
00394                                                 1, 1), 
00395                           env);
00396   scheme_add_global_constant("split-path", 
00397                           scheme_make_prim_w_arity2(split_path,
00398                                                  "split-path",
00399                                                  1, 1,
00400                                                  3, 3), 
00401                           env);
00402   scheme_add_global_constant("relative-path?", 
00403                           scheme_make_prim_w_arity(relative_path_p,
00404                                                 "relative-path?",
00405                                                 1, 1), 
00406                           env);
00407   scheme_add_global_constant("absolute-path?", 
00408                           scheme_make_prim_w_arity(absolute_path_p,
00409                                                 "absolute-path?",
00410                                                 1, 1), 
00411                           env);
00412   scheme_add_global_constant("complete-path?", 
00413                           scheme_make_prim_w_arity(complete_path_p,
00414                                                 "complete-path?",
00415                                                 1, 1), 
00416                           env);
00417   scheme_add_global_constant("path->complete-path",
00418                           scheme_make_prim_w_arity(path_to_complete_path,
00419                                                 "path->complete-path",
00420                                                 1, 2), 
00421                           env);
00422   scheme_add_global_constant("resolve-path",
00423                           scheme_make_prim_w_arity(resolve_path,
00424                                                 "resolve-path",
00425                                                 1, 1), 
00426                           env);
00427   scheme_add_global_constant("simplify-path",
00428                           scheme_make_prim_w_arity(simplify_path,
00429                                                 "simplify-path",
00430                                                 1, 2), 
00431                           env);
00432   scheme_add_global_constant("cleanse-path",
00433                           scheme_make_prim_w_arity(cleanse_path,
00434                                                 "cleanse-path",
00435                                                 1, 1), 
00436                           env);
00437   scheme_add_global_constant("expand-user-path",
00438                           scheme_make_prim_w_arity(expand_user_path,
00439                                                 "expand-user-path",
00440                                                 1, 1), 
00441                           env);
00442   scheme_add_global_constant("directory-list",
00443                           scheme_make_prim_w_arity(directory_list,
00444                                                 "directory-list",
00445                                                 0, 1), 
00446                           env);
00447   scheme_add_global_constant("filesystem-root-list",
00448                           scheme_make_prim_w_arity(filesystem_root_list,
00449                                                 "filesystem-root-list",
00450                                                 0, 0), 
00451                           env);
00452   scheme_add_global_constant("make-directory",
00453                           scheme_make_prim_w_arity(make_directory,
00454                                                 "make-directory",
00455                                                 1, 1), 
00456                           env);
00457   scheme_add_global_constant("delete-directory",
00458                           scheme_make_prim_w_arity(delete_directory,
00459                                                 "delete-directory",
00460                                                 1, 1), 
00461                           env);
00462   scheme_add_global_constant("make-file-or-directory-link",
00463                           scheme_make_prim_w_arity(make_link,
00464                                                 "make-file-or-directory-link",
00465                                                 2, 2), 
00466                           env);
00467   scheme_add_global_constant("file-or-directory-modify-seconds",
00468                           scheme_make_prim_w_arity(file_modify_seconds,
00469                                                 "file-or-directory-modify-seconds",
00470                                                 1, 3), 
00471                           env);
00472   scheme_add_global_constant("file-or-directory-permissions",
00473                           scheme_make_prim_w_arity(file_or_dir_permissions,
00474                                                 "file-or-directory-permissions",
00475                                                 1, 1), 
00476                           env);
00477   scheme_add_global_constant("file-size",
00478                           scheme_make_prim_w_arity(file_size,
00479                                                 "file-size",
00480                                                 1, 1), 
00481                           env);
00482 
00483   scheme_add_global_constant("current-drive", 
00484                           scheme_make_prim_w_arity(current_drive, 
00485                                                 "current-drive", 
00486                                                 0, 0), 
00487                           env);
00488 
00489   scheme_add_global_constant("find-system-path", 
00490                           scheme_make_prim_w_arity(find_system_path, 
00491                                                 "find-system-path", 
00492                                                 1, 1), 
00493                           env);
00494 
00495 #endif
00496 
00497 #ifdef DIR_FUNCTION
00498   scheme_add_global_constant("current-directory",
00499                           scheme_register_parameter(current_directory,
00500                                                  "current-directory", 
00501                                                  MZCONFIG_CURRENT_DIRECTORY),
00502                           env);
00503 #endif
00504 
00505 #ifndef NO_FILE_SYSTEM_UTILS
00506   scheme_add_global_constant("current-library-collection-paths",
00507                           scheme_register_parameter(current_library_collection_paths,
00508                                                  "current-library-collection-paths",
00509                                                  MZCONFIG_COLLECTION_PATHS),
00510                           env);
00511 #endif
00512   scheme_add_global_constant("use-compiled-file-paths",
00513                           scheme_register_parameter(use_compiled_kind,
00514                                                  "use-compiled-file-paths",
00515                                                  MZCONFIG_USE_COMPILED_KIND),
00516                           env);
00517   scheme_add_global_constant("use-user-specific-search-paths",
00518                           scheme_register_parameter(use_user_paths,
00519                                                  "use-user-specific-search-paths",
00520                                                  MZCONFIG_USE_USER_PATHS),
00521                           env);
00522 }
00523 
00524 /**********************************************************************/
00525 /*                             paths                                  */
00526 /**********************************************************************/
00527 
00528 Scheme_Object *scheme_make_sized_offset_kind_path(char *chars, long d, long len, int copy, int kind)
00529 {
00530   Scheme_Object *s;
00531   s = scheme_make_sized_offset_byte_string(chars, d, len, copy);
00532   s->type = kind;
00533   return s;
00534 }
00535 
00536 Scheme_Object *scheme_make_sized_offset_path(char *chars, long d, long len, int copy)
00537 {
00538   return scheme_make_sized_offset_kind_path(chars, d, len, copy, SCHEME_PLATFORM_PATH_KIND);
00539 }
00540 
00541 # define IS_SPEC_CHAR(x) (IS_A_DOS_SEP(x) || ((x) == '"') || ((x) == '|') || ((x) == ':') || ((x) == '<') || ((x) == '>'))
00542 static int is_special_filename(const char *_f, int offset, int len, int not_nul, int immediate);
00543 
00544 static Scheme_Object *make_protected_sized_offset_path(int protect, char *chars, 
00545                                                  long d, long len, int copy,
00546                                                  int just_check, int kind)
00547      /* just_check == 2 => just check, and only for the case
00548        that it's the last element of a path */
00549 {
00550   if (kind == SCHEME_WINDOWS_PATH_KIND) {
00551     if (protect) {
00552       int i;
00553 
00554       protect = 0;
00555 
00556       if (!protect) {
00557         int at_end = 1;
00558         for (i = len; i--; ) {
00559           if ((just_check != 2)
00560               && ((chars[i + d] == '.')
00561                   || (chars[i + d] == ' '))) {
00562             if (at_end) {
00563               protect = 1;
00564               break;
00565             }
00566           } else {
00567             at_end = 0;
00568             if ((chars[i + d] == '/')
00569                 || (IS_SPEC_CHAR(chars[i + d]))) {
00570               protect = 1;
00571               break;
00572             }
00573           }
00574         }
00575       }
00576 
00577       if (!protect && (len == 1) && (chars[d] == '.'))
00578         protect = 1;
00579 
00580       if (!protect && (len == 2) && (chars[d] == '.') && (chars[d+1] == '.'))
00581         protect = 1;
00582 
00583       if (!protect) 
00584         protect = is_special_filename(chars, d, len, 0, 1);
00585 
00586       if (protect) {
00587         char *s2;
00588         if (just_check)
00589           return scheme_true;
00590         s2 = (char *)scheme_malloc_atomic(len + 9 + 1);
00591         memcpy(s2, "\\\\?\\REL\\\\", 9);
00592         memcpy(s2 + 9, chars + d, len);
00593         s2[9 + len] = 0;
00594         return scheme_make_sized_offset_kind_path(s2, 0, len + 9, 0, SCHEME_WINDOWS_PATH_KIND);
00595       }
00596     }
00597   } else {
00598 #ifdef TILDE_IS_ABSOLUTE
00599     if (protect) {
00600       if (chars[d] == '~') {
00601         char *nm;
00602         if (just_check)
00603           return scheme_true;
00604         nm = (char *)scheme_malloc_atomic(len + 3);
00605         memcpy(nm XFORM_OK_PLUS 2, chars XFORM_OK_PLUS d, len);
00606         nm[0] = '.';
00607         nm[1] = '/';
00608         nm[len + 2] = 0;
00609         return scheme_make_sized_offset_kind_path(nm, 0, len + 2, 0, kind);
00610       }
00611     }
00612 #endif
00613   }
00614 
00615   if (just_check)
00616     return scheme_false;
00617 
00618   return scheme_make_sized_offset_kind_path(chars, d, len, copy, kind);
00619 }
00620 
00621 #ifdef DOS_FILE_SYSTEM
00622 static Scheme_Object *make_protected_path(char *chars)
00623 {
00624   return make_protected_sized_offset_path(1, chars, 0, strlen(chars), 1, 0, SCHEME_WINDOWS_PATH_KIND);
00625 }
00626 #endif
00627 
00628 Scheme_Object *make_exposed_sized_offset_path(int already_protected, 
00629                                          char *chars, long d, long len, int copy,
00630                                               int kind)
00631   /* Called to make a directory path where the end has been removed.
00632      We may need to remove a redundant separator.
00633      Under Windows, if the resulting last element has spaces or is a 
00634      special file, then we need to protect it with "\\?\". */
00635 {
00636   if (kind == SCHEME_WINDOWS_PATH_KIND) {
00637     if (!already_protected) {
00638       int i, name_end;
00639       int non_dot = 0, trailing_dots = 0, protect = 0;
00640       /* Skip trailing seps: */
00641       for (i = d + len - 1; (i > d) && IS_A_DOS_SEP(chars[i]); --i) {
00642       }
00643       name_end = i+1;
00644       for (; (i > d) && !IS_A_DOS_SEP(chars[i]); --i) {
00645         if ((chars[i] != ' ') && (chars[i] != '.'))
00646           non_dot = 1;
00647         else if (!non_dot)
00648           trailing_dots = 1;
00649       }
00650       if (non_dot && trailing_dots)
00651         protect = 1;
00652       else if (name_end == (d + len))
00653         protect = is_special_filename(chars, i+1, name_end, 0, 1);
00654 
00655       if (protect) {
00656         Scheme_Object *first, *last, *a[2];
00657         char *s2;
00658         int l;
00659         l = name_end - (i+1);
00660         s2 = (char *)scheme_malloc_atomic(l + 9 + 1);
00661         memcpy(s2, "\\\\?\\REL\\\\", 9);
00662         memcpy(s2+9, chars + i + 1, l);
00663         s2[l + 9] = 0;
00664         last = scheme_make_sized_offset_kind_path(s2, 0, l+9, 0, SCHEME_WINDOWS_PATH_KIND);
00665         first = make_exposed_sized_offset_path(0, chars, d, i-d+1, 1, SCHEME_WINDOWS_PATH_KIND);
00666         a[0] = first;
00667         a[1] = last;
00668         return scheme_build_path(2, a);
00669       }
00670     }
00671   }
00672 
00673   /* We may need to remove a redundant separator from the directory
00674      path. Try removing it, and see if anyone would care: */
00675   if (do_path_to_directory_path(chars, d, len - 1, scheme_true, 1, kind)) {
00676     /* Actually, don't remove a separator after a drive, although it's
00677        technically redundant. */
00678     if ((kind != SCHEME_WINDOWS_PATH_KIND)
00679         || !((len == 3) && is_drive_letter(chars[d]) && (chars[d+1] == ':'))) {
00680       len--;
00681       copy = 1;
00682     }
00683   }
00684 
00685   return scheme_make_sized_offset_kind_path(chars, d, len, copy, kind);
00686 }
00687 
00688 Scheme_Object *scheme_make_path(const char *chars)
00689 {
00690   return scheme_make_sized_offset_path((char *)chars, 0, -1, 1);
00691 }
00692 
00693 Scheme_Object *scheme_make_sized_path(char *chars, long len, int copy)
00694 {
00695   return scheme_make_sized_offset_path(chars, 0, len, copy);
00696 }
00697 
00698 Scheme_Object *scheme_make_path_without_copying(char *chars)
00699 {
00700   return scheme_make_sized_offset_path(chars, 0, -1, 0);
00701 }
00702 
00703 static Scheme_Object *append_path(Scheme_Object *a, Scheme_Object *b)
00704 {
00705   Scheme_Object *s;
00706   s = scheme_append_byte_string(a, b);
00707   s->type = SCHEME_PLATFORM_PATH_KIND;
00708   return s;
00709 }
00710 
00711 Scheme_Object *scheme_char_string_to_path(Scheme_Object *p)
00712 {
00713   p = scheme_char_string_to_byte_string_locale(p);
00714   p->type = SCHEME_PLATFORM_PATH_KIND;
00715   return p;
00716 }
00717 
00718 
00719 static Scheme_Object *path_p(int argc, Scheme_Object **argv)
00720 {
00721   return (SCHEME_PATHP(argv[0]) ? scheme_true : scheme_false);
00722 }
00723 
00724 static Scheme_Object *general_path_p(int argc, Scheme_Object **argv)
00725 {
00726   return (SCHEME_GENERAL_PATHP(argv[0]) ? scheme_true : scheme_false);
00727 }
00728 
00729 static Scheme_Object *path_kind(int argc, Scheme_Object **argv)
00730 {
00731   if (SCHEME_GENERAL_PATHP(argv[0])) {
00732     switch (SCHEME_PATH_KIND(argv[0])) {
00733     case SCHEME_WINDOWS_PATH_KIND:
00734       return windows_symbol;
00735       break;
00736     default:
00737     case SCHEME_UNIX_PATH_KIND:
00738       return unix_symbol;
00739       break;
00740     }
00741   } else {
00742     scheme_wrong_type("path-system-type", "path (for any system)", 0, argc, argv);
00743     return NULL;
00744   }
00745 }
00746 
00747 static Scheme_Object *platform_path_kind(int argc, Scheme_Object **argv)
00748 {
00749   switch (SCHEME_PLATFORM_PATH_KIND) {
00750   case SCHEME_WINDOWS_PATH_KIND:
00751     return windows_symbol;
00752     break;
00753   default:
00754   case SCHEME_UNIX_PATH_KIND:
00755     return unix_symbol;
00756     break;
00757   }
00758 }
00759 
00760 static Scheme_Object *drop_rel_prefix(Scheme_Object *p)
00761 /* Drop \\?\REL\ prefix */
00762 {
00763   int drive_end;
00764   if (check_dos_slashslash_qm(SCHEME_PATH_VAL(p),
00765                               SCHEME_PATH_LEN(p),
00766                               &drive_end, NULL, NULL)) {
00767     if (drive_end < 0) {
00768       /* \\?\REL\ */
00769       int delta;
00770       if (SCHEME_PATH_VAL(p)[8] == '\\')
00771         delta = 9;
00772       else
00773         delta = 8;
00774       p = scheme_make_sized_offset_kind_path(SCHEME_BYTE_STR_VAL(p),
00775                                              delta,
00776                                              SCHEME_BYTE_STRLEN_VAL(p) - delta,
00777                                              1,
00778                                              SCHEME_WINDOWS_PATH_KIND);
00779     }
00780   }
00781 
00782   return p;
00783 }
00784 
00785 Scheme_Object *scheme_path_to_char_string(Scheme_Object *p)
00786 {
00787   Scheme_Object *s;
00788 
00789   s = scheme_byte_string_to_char_string_locale(p);
00790 
00791   if (!SCHEME_CHAR_STRLEN_VAL(s))
00792     return scheme_make_utf8_string("?");
00793   else
00794     return s;
00795 }
00796 
00797 static Scheme_Object *path_to_string(int argc, Scheme_Object **argv)
00798 {
00799   if (!SCHEME_PATHP(argv[0]))
00800     scheme_wrong_type("path->string", "path", 0, argc, argv);
00801 
00802   return scheme_path_to_char_string(argv[0]);
00803 }
00804 
00805 static Scheme_Object *path_to_bytes(int argc, Scheme_Object **argv)
00806 {
00807   if (!SCHEME_GENERAL_PATHP(argv[0]))
00808     scheme_wrong_type("path->bytes", "path", 0, argc, argv);
00809 
00810   return scheme_make_sized_byte_string(SCHEME_PATH_VAL(argv[0]),
00811                                    SCHEME_PATH_LEN(argv[0]),
00812                                    1);
00813 }
00814 
00815 static Scheme_Object *is_path_element(Scheme_Object *p)
00816 {
00817   Scheme_Object *base, *fn;
00818   int isdir;
00819 
00820   fn = scheme_split_path(SCHEME_PATH_VAL(p), 
00821                          SCHEME_PATH_LEN(p), 
00822                          &base, 
00823                          &isdir,
00824                          SCHEME_PATH_KIND(p));
00825 
00826   if (SCHEME_SYMBOLP(base)
00827       && SCHEME_GENERAL_PATHP(fn))
00828     return fn;
00829   return NULL;
00830 }
00831 
00832 static Scheme_Object *do_path_element_to_bytes(const char *name, int argc, Scheme_Object **argv)
00833 {
00834   Scheme_Object *p = argv[0], *pe;
00835   int kind;
00836 
00837   if (!SCHEME_GENERAL_PATHP(p))
00838     scheme_wrong_type(name, "path", 0, argc, argv);
00839   
00840   pe = is_path_element(p);
00841 
00842   if (!pe)
00843     scheme_arg_mismatch(name,
00844                         "path can be split or is not relative: ",
00845                         p);
00846 
00847   if (SCHEME_SYMBOLP(pe)) {
00848     scheme_arg_mismatch(name,
00849                         (SAME_OBJ(pe, up_symbol)
00850                          ? "path is an up-directory indicator: "
00851                          : "path is a same-directory indicator: "),
00852                         p);
00853   }
00854 
00855   p = pe;
00856 
00857   kind = SCHEME_PATH_KIND(p);
00858 
00859   if (kind == SCHEME_UNIX_PATH_KIND) {
00860 #ifdef TILDE_IS_ABSOLUTE
00861     /* Drop ./ of ./~ prefix */
00862     if ((SCHEME_PATH_VAL(p)[0] == '.')
00863         && (SCHEME_PATH_VAL(p)[1] == '/')
00864         && (SCHEME_PATH_VAL(p)[2] == '~')) {
00865       p = scheme_make_sized_offset_byte_string(SCHEME_PATH_VAL(p), 
00866                                                2, 
00867                                                SCHEME_PATH_LEN(p) - 2, 
00868                                                1);
00869     }
00870 #endif
00871   }
00872   if (kind == SCHEME_WINDOWS_PATH_KIND) {
00873     p = drop_rel_prefix(p);
00874   }
00875 
00876   return scheme_make_sized_byte_string(SCHEME_PATH_VAL(p),
00877                                    SCHEME_PATH_LEN(p),
00878                                    1);
00879 }
00880 
00881 static Scheme_Object *path_element_to_bytes(int argc, Scheme_Object **argv)
00882 {
00883   return do_path_element_to_bytes("path-element->bytes", argc, argv);
00884 }
00885 
00886 static Scheme_Object *path_element_to_string(int argc, Scheme_Object **argv)
00887 {
00888   Scheme_Object *b;
00889   b = do_path_element_to_bytes("path-element->string", argc, argv);
00890   return scheme_byte_string_to_char_string_locale(b);
00891 }
00892 
00893 static void check_path_ok(const char *who, Scheme_Object *p, Scheme_Object *o)
00894 {
00895   if (has_null(SCHEME_PATH_VAL(p), SCHEME_PATH_LEN(p))) {
00896     raise_null_error(who, o, "");
00897   }
00898 }
00899 
00900 static Scheme_Object *string_to_path(int argc, Scheme_Object **argv)
00901 {
00902   Scheme_Object *p;
00903 
00904   if (!SCHEME_CHAR_STRINGP(argv[0]))
00905     scheme_wrong_type("string->path", "string", 0, argc, argv);
00906 
00907   p = scheme_char_string_to_path(argv[0]);
00908   
00909   check_path_ok("string->path", p, argv[0]);
00910 
00911   return p;
00912 }
00913 
00914 static int extract_path_kind(const char *who, int which, int argc, Scheme_Object **argv)
00915 {
00916   if (which >= argc)
00917     return SCHEME_PLATFORM_PATH_KIND;
00918   
00919   if (SAME_OBJ(argv[which], windows_symbol))
00920     return SCHEME_WINDOWS_PATH_KIND;
00921   if (SAME_OBJ(argv[which], unix_symbol))
00922     return SCHEME_UNIX_PATH_KIND;
00923 
00924   scheme_wrong_type(who, "'unix or 'windows", which, argc, argv);
00925   return 0;
00926 }
00927 
00928 static Scheme_Object *bytes_to_path(int argc, Scheme_Object **argv)
00929 {
00930   Scheme_Object *s;
00931   int kind;
00932 
00933   if (!SCHEME_BYTE_STRINGP(argv[0]))
00934     scheme_wrong_type("bytes->path", "byte string", 0, argc, argv);
00935   kind = extract_path_kind("bytes->path", 1, argc, argv);
00936 
00937   s = scheme_make_sized_byte_string(SCHEME_BYTE_STR_VAL(argv[0]),
00938                                 SCHEME_BYTE_STRLEN_VAL(argv[0]),
00939                                 SCHEME_MUTABLEP(argv[0]));
00940   s->type = kind;
00941 
00942   check_path_ok("bytes->path", s, argv[0]);
00943 
00944   return s;
00945 }
00946 
00947 static Scheme_Object *do_bytes_to_path_element(const char *name, Scheme_Object *s, int argc, Scheme_Object **argv)
00948 {
00949   Scheme_Object *p;
00950   long i, len;
00951   int kind;
00952 
00953   if (!SCHEME_BYTE_STRINGP(s))
00954     scheme_wrong_type(name, "byte string", 0, argc, argv);
00955   kind = extract_path_kind(name, 1, argc, argv);
00956 
00957   len = SCHEME_BYTE_STRLEN_VAL(s);
00958   for (i = 0; i < len; i++) {
00959     if (IS_A_PRIM_SEP(kind, SCHEME_BYTE_STR_VAL(s)[i])) {
00960       break;
00961     }
00962   }
00963 
00964   if (i >= len)
00965     p = make_protected_sized_offset_path(1, SCHEME_BYTE_STR_VAL(s),
00966                                          0, len,
00967                                          SCHEME_MUTABLEP(s), 0,
00968                                          kind);
00969   else
00970     p = NULL;
00971 
00972   if (!p || !is_path_element(p))
00973     scheme_arg_mismatch(name,
00974                         "cannot be converted to a path element (can be split, is not relative, or names a special element): ",
00975                         argv[0]);
00976 
00977   return p;
00978 }
00979 
00980 static Scheme_Object *bytes_to_path_element(int argc, Scheme_Object **argv)
00981 {
00982   return do_bytes_to_path_element("bytes->path-element", argv[0], argc, argv);
00983 }
00984 
00985 static Scheme_Object *string_to_path_element(int argc, Scheme_Object **argv)
00986 {
00987   Scheme_Object *b;
00988 
00989   if (!SCHEME_CHAR_STRINGP(argv[0]))
00990     scheme_wrong_type("string->path-element", "string", 0, argc, argv);
00991 
00992   b = scheme_char_string_to_byte_string_locale(argv[0]);
00993   
00994   return do_bytes_to_path_element("string->path-element", b, argc, argv);
00995 }
00996 
00997 /**********************************************************************/
00998 /*                                                                    */
00999 /**********************************************************************/
01000 
01001 
01002 #ifdef DOS_FILE_SYSTEM
01003 static char *mz_getcwd(char *s, int l)
01004 {
01005  int need_l, bl = 256;
01006  wchar_t buffer[256], *wbuf;
01007 
01008  wbuf = buffer;
01009  while (1) {
01010    need_l = GetCurrentDirectoryW(bl, wbuf);
01011    if (need_l > bl) {
01012      wbuf = (wchar_t *)scheme_malloc_atomic(need_l * sizeof(wchar_t));
01013      bl = need_l;
01014    } else
01015      break;
01016  }
01017 
01018  if (!need_l)
01019    return NULL;
01020  
01021  bl = scheme_utf8_encode((unsigned int *)wbuf, 0, need_l, NULL, 0, 1 /*UTF-16*/);
01022  if (bl + 1 > l) {
01023    s = (char *)scheme_malloc_atomic(bl + 1);
01024  }
01025  bl = scheme_utf8_encode((unsigned int *)wbuf, 0, need_l, s, 0, 1 /*UTF-16*/);
01026  s[bl] = 0;
01027 
01028  return s;
01029 }
01030 #else
01031 # define mz_getcwd MSC_IZE(getcwd)
01032 #endif
01033 
01034 char *scheme_os_getcwd(char *buf, int buflen, int *actlen, int noexn)
01035 {
01036 # define GETCWD_BUFSIZE 1024
01037   char buffer[GETCWD_BUFSIZE], *r, *gbuf;
01038   int obuflen = buflen;
01039 
01040   if (buflen < GETCWD_BUFSIZE) {
01041     gbuf = buffer;
01042     buflen = GETCWD_BUFSIZE;
01043   } else
01044     gbuf = buf;
01045 
01046   r = mz_getcwd(gbuf, buflen - 1);
01047   if (!r) {
01048     char *r2;
01049 
01050     r = mz_getcwd(NULL, 0);
01051     if (!r) {
01052       /* Something bad happened! */
01053       if (noexn) {
01054         /* We need to invent some complete path. */
01055 #ifdef DOS_FILE_SYSTEM
01056         r = "C:\\";
01057 #else
01058         r = "/";
01059 #endif        
01060        if (actlen)
01061          *actlen = strlen(r);
01062 
01063        if (buf) {
01064           strcpy(buf, r);
01065          return buf;
01066        } else {
01067          return r;
01068        }
01069       }
01070        
01071       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, 
01072                      "current-directory: unknown failure (%e)", errno);
01073     }
01074 
01075     buflen = strlen(r) + 1;
01076     r2 = (char *)scheme_malloc_atomic(buflen);
01077     memcpy(r2, r, buflen);
01078     r2[buflen] = 0;
01079     free(r);
01080     r = r2;
01081 
01082     if (actlen)
01083       *actlen = buflen;
01084   } else {
01085     int slen = strlen(r) + 1;
01086 
01087     if (actlen)
01088       *actlen = slen;
01089 
01090     if (obuflen < slen)
01091       r = scheme_strdup(r);
01092     else if (r != buf) {
01093       memcpy(buf, r, slen);
01094       r = buf;
01095     }
01096   }
01097      
01098   return r;
01099 }
01100 
01101 int scheme_os_setcwd(char *expanded, int noexn)
01102 {
01103   int err;
01104 
01105   while (1) {
01106     err = MSC_W_IZE(chdir)(MSC_WIDE_PATH(expanded));
01107     if (!err || (errno != EINTR))
01108       break;
01109   }
01110 
01111   if (err && !noexn)
01112       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
01113                      "current-directory: unable to switch to directory: \"%q\"",
01114                      expanded);
01115 
01116   return !err;
01117 }
01118 
01119 #ifdef DOS_FILE_SYSTEM
01120 #define WC_BUFFER_SIZE 1024
01121 static wchar_t wc_buffer[WC_BUFFER_SIZE];
01122 
01123 static int wc_strlen(const wchar_t *ws)
01124 {
01125   int l;
01126   for (l =0; ws[l]; l++) { }
01127   return l;
01128 }
01129 
01130 wchar_t *scheme_convert_to_wchar(const char *s, int do_copy)
01131      /* This function uses '\t' in place of invalid UTF-8 encoding
01132        bytes, because '\t' is not a legal filename under Windows. */
01133 {
01134   long len, l;
01135   wchar_t *ws;
01136 
01137   l = strlen(s);
01138   len = scheme_utf8_decode(s, 0, l,
01139                         NULL, 0, -1,
01140                         NULL, 1/*UTF-16*/, '\t');
01141 
01142   if (!do_copy && (len < (WC_BUFFER_SIZE-1)))
01143     ws = wc_buffer;
01144   else
01145     ws = (wchar_t *)scheme_malloc_atomic(sizeof(wchar_t) * (len + 1));
01146   scheme_utf8_decode(s, 0, l,
01147                    (unsigned int *)ws, 0, -1,
01148                    NULL, 1/*UTF-16*/, '\t');
01149   ws[len] = 0;
01150   return ws;
01151 }
01152 
01153 char *scheme_convert_from_wchar(const wchar_t *ws)
01154 {
01155   long len, l;
01156   char *s;
01157 
01158   l = wc_strlen(ws);
01159   len = scheme_utf8_encode((unsigned int *)ws, 0, l,
01160                         NULL, 0,
01161                         1/*UTF-16*/);
01162   s = (char *)scheme_malloc_atomic(len + 1);
01163   scheme_utf8_encode((unsigned int *)ws, 0, l,
01164                    s, 0,
01165                    1/*UTF-16*/);
01166   s[len] = 0;
01167   return s;
01168 }
01169 #endif
01170 
01171 
01172 Scheme_Object *scheme_get_file_directory(const char *filename)
01173 {
01174   int isdir;
01175   Scheme_Object *base;
01176   
01177   scheme_split_path(filename, strlen(filename), &base, &isdir, SCHEME_PLATFORM_PATH_KIND);
01178   
01179   return base;
01180 }
01181 
01182 Scheme_Object *scheme_remove_current_directory_prefix(Scheme_Object *fn)
01183 {
01184   Scheme_Object *cwd;
01185   long len;
01186 
01187   cwd = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_DIRECTORY);
01188 
01189   fn = TO_PATH(fn);
01190 
01191   len = SCHEME_PATH_LEN(cwd);
01192   if ((len < SCHEME_PATH_LEN(fn))
01193       && !scheme_strncmp(SCHEME_PATH_VAL(cwd), SCHEME_PATH_VAL(fn), len)) {
01194     /* Skip over path separators: */
01195     while (IS_A_SEP(SCHEME_PLATFORM_PATH_KIND, SCHEME_PATH_VAL(fn)[len])) {
01196       len++;
01197     }
01198 
01199     return scheme_make_sized_offset_path(SCHEME_PATH_VAL(fn), len, SCHEME_PATH_LEN(fn) - len, 1);
01200   }
01201 
01202   return fn;
01203 }
01204 
01205 static int has_null(const char *s, long l)
01206 {
01207   if (!l)
01208     return 1;
01209 
01210   while (l--) {
01211     if (!s[l])
01212       return 1;
01213   }
01214 
01215   return 0;
01216 }
01217 
01218 static void raise_null_error(const char *name, Scheme_Object *path, const char *mod)
01219 {
01220   if (!(SCHEME_CHAR_STRINGP(path) ? SCHEME_CHAR_STRTAG_VAL(path) : SCHEME_PATH_LEN(path)))
01221     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01222                    "%s: path string%s is empty", 
01223                    name, mod);
01224   else
01225     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
01226                    "%s: path string%s contains a null character: %Q", 
01227                    name, mod, 
01228                    path);
01229 }
01230 
01231 static int check_dos_slashslash_qm(const char *next, int len, 
01232                                int *drive_end, int *clean_start, int *add_sep)
01233 /* Check starting with exactly \\?\, which prefixes an absolute path
01234    to be passed on to the filesystem without changes.
01235 
01236    If it's a \\?\ path, then drive_end is set to the first character
01237    after the root specification. For example, if the drive is
01238    terminated by \\\ (a weird "root"), then drive_end is set to after
01239    the third \.  If the drive is \\?\C:\, then drive_end is after the
01240    last slash, unless thre's one extra slash, in which case drive_end
01241    is after that slash, too. In the case of \\?\UNC\..., drive_end
01242    is after the UNC part as in check_dos_slashslash_drive(). If
01243    it's a \\?\REL\ or \\?\RED\ path, then drive_end is set to -1(!)
01244    or -2(!)!; use get_slashslash_qm_dot_ups_end() to get more information.
01245 
01246    clean_start is the position where it's ok to start removing
01247    extra slahes. It's usually set to the same thing as drive_end. In the
01248    case of a \\?\UNC\ path, clean_start is set to 7 (i.e., just after
01249    that prefix). In the case of a \\?\REL\ or \\?\RED\ path, clean_start
01250    is the end of the string.
01251 
01252    If add_sep is set, it points to a place where an extra separator
01253    might need to be inserted.
01254 */
01255 {
01256   if ((len >= 4)
01257       && (next[0] == '\\')
01258       && (next[1] == '\\')
01259       && (next[2] == '?')
01260       && (next[3] == '\\')) {
01261     int base;
01262     if (!drive_end && !clean_start && !add_sep)
01263       return 1;
01264     if (next[4] == '\\')
01265       base = 5;
01266     else
01267       base = 4;
01268     /* If there's two backslashes in a row at the end, count everything
01269        as the drive. There are two exceptions: two backslashes are ok
01270        at the end in the form \\?\C:\\, and \\?\\\ is \\?\ */
01271     if ((len > 5)
01272        && (next[len - 1] == '\\')
01273        && (next[len - 2] == '\\')) {
01274       if (len == 6) {
01275        /* \\?\ is the root */
01276       } else if ((len != 8)
01277          || !is_drive_letter(next[base])
01278          || (next[base+1] != ':')) {
01279        if (drive_end)
01280          *drive_end = len;
01281        if (clean_start)
01282          *clean_start = len;
01283        if (add_sep)
01284          *add_sep = len;
01285        return 1;
01286       }
01287     }
01288     /* If there's three backslashes in a row, count everything
01289        up to the slashes as the drive. */
01290     if (len > 6) {
01291       int i;
01292       for (i = len; --i > 5; ) {
01293        if ((next[i] == '\\')
01294            && (next[i-1] == '\\')
01295            && (next[i-2] == '\\')) {
01296          if (drive_end)
01297            *drive_end = i+1;
01298          if (clean_start)
01299            *clean_start = i+1;
01300          return 1;
01301        }
01302       }
01303     }
01304 
01305     if ((len > 6)
01306        && is_drive_letter(next[base])
01307        && next[base+1] == ':'
01308        && next[base+2] == '\\') {
01309       if (clean_start)
01310        *clean_start = base+2;
01311       if (drive_end) {
01312        if ((len > base+3) && next[base+3] == '\\')
01313          *drive_end = base+4;
01314        else
01315          *drive_end = base+3;
01316       }
01317     } else if ((len > base+3)
01318               && ((next[base] == 'U') || (next[base] == 'u'))
01319               && ((next[base+1] == 'N') || (next[base+1] == 'n'))
01320               && ((next[base+2] == 'C') || (next[base+2] == 'c'))
01321               && (next[base+3] == '\\')
01322               && check_dos_slashslash_drive(next, 
01323                                         (((len > (base+4)) && (next[base+4] == '\\'))
01324                                          ? base+5
01325                                          : base+4),
01326                                         len, drive_end, 0, 1)) {
01327       /* drive_end set by check_dos_slashslash_drive */
01328       if (clean_start)
01329        *clean_start = base+3;
01330     } else if ((base == 4) 
01331               && (len > 8)
01332               && (next[4] == 'R')
01333               && (next[5] == 'E')
01334               && ((next[6] == 'L') || (next[6] == 'D'))
01335               && (next[7] == '\\')
01336               && ((next[8] != '\\')
01337                  || (len > 9))) { 
01338       if (drive_end)
01339        *drive_end = ((next[6] == 'L') ? -1 : -2);
01340       if (clean_start)
01341        *clean_start = len; /* caller will have to use get_slashslash_qm_dot_ups_end */
01342     } else {
01343       if (drive_end)
01344        *drive_end = 4;
01345       if (clean_start) {
01346        if (((len == 5) && (next[4] == '\\'))
01347            || ((len == 6) && (next[4] == '\\') && (next[5] == '\\')))
01348          *clean_start = 3;
01349        else
01350          *clean_start = 4;
01351       }
01352       if (add_sep)
01353        *add_sep = 4;
01354     }
01355     return 1;
01356   }
01357   return 0;
01358 }
01359 
01360 static int check_dos_slashslash_drive(const char *next, int delta, int len, 
01361                                   int *drive_end, int exact, int no_fw)
01362 /* Returns 1 if this path is a UNC path, 0 otherwise.
01363    (It starts by checking for \\?\ paths, so they won't be
01364    treated as UNC. Unless delta is non-0, in which case the
01365    check isn't necessary, presumably because the original
01366    `next' already started with \\?\UNC\.)
01367    For a 1 result, drive_end (if not NULL) is set to point to the
01368    byte after the \\server\vol; so, drive_end points to either
01369    a separator or NUL char.
01370    If exact is 1, then a 1 is returned only if `next' is just the
01371    drive; that is, only if 1 would be returned and only slashes are
01372    in `next' starting with `*drive_end'.
01373    If `no_fw' is set, then only backslashes are recognized.
01374 */
01375 {
01376   int j;
01377   int is_drive = 0;
01378 
01379   if (drive_end)
01380     *drive_end = len;
01381 
01382   if (!delta && check_dos_slashslash_qm(next, len, NULL, NULL, NULL))
01383     return 0;
01384 
01385 #define IS_X_SEP(c) (no_fw ? (c == '\\') : IS_A_DOS_SEP(c))
01386 
01387   if (delta || (IS_A_DOS_SEP(next[0]) && IS_A_DOS_SEP(next[1]))) {
01388     /* Found two separators... */
01389     /* Check for a drive form: //x/y */
01390     j = delta ? delta : 2;
01391     if (!IS_X_SEP(next[j])) {
01392       /* Found non-sep; skip over more */
01393       for (; j < len; j++) {
01394        if (IS_X_SEP(next[j])) {
01395          /* Found sep again, so we have //x/: */
01396          j++;
01397          if (no_fw && (j < len) && IS_X_SEP(next[j]))
01398            j++; /* two backslashes ok in \\?\UNC mode */
01399          if ((j == (delta ? (delta + 2) : 4))
01400              && (next[j - 2] == '?')) {
01401            /* We have //?/, with up to 2 backslashes.
01402               This doesn't count as UNC, to avoid confusion with \\?\. */
01403          } else if ((j < len) && !IS_X_SEP(next[j])) {
01404            /* Found non-sep again; this is UNC */
01405            for (; j < len; j++) {
01406              if (IS_X_SEP(next[j])) {
01407               /* Found sep again. */
01408               if (drive_end)
01409                 *drive_end = j;
01410               if (exact) {
01411                 for (; j < len; j++) {
01412                   if (!IS_X_SEP(next[j])) {
01413                     /* Found non-sep again 
01414                       - not a drive (it's absolute path) */
01415                     break;
01416                   }
01417                 }
01418               } else
01419                 is_drive = 1;
01420               break;
01421              }
01422            }
01423            if (j >= len)
01424              is_drive = 1;
01425            break;
01426          }
01427          break;
01428        } else if (IS_A_DOS_SEP(next[j])) {
01429          /* Found / when only \ is allowed as separator */
01430          break;
01431        }
01432       }
01433     }
01434   }
01435 
01436   return is_drive;
01437 }
01438 
01439 static int get_slashslash_qm_dot_ups_end(const char *s, int len, int *_lit_start)
01440   /* If str is of the form \\?\REL\..\..\.., returns the index just
01441      past the last "\..". This might be the first "\" of a "\\"
01442      separator, the "\" before a non-".." element, or the end of the
01443      string. For a \\?\RED\ path, it's as if there are no ".."s
01444      (because ".." is not special in "RED" paths).  The _lit_start
01445      value is filled with the starting index of the literal part of
01446      the path (i.e., after one or two slashes). */
01447 {
01448   int pos = -1, j = 7; /* \\?\REL\ or \\?\RED\ */
01449 
01450   if (s[6] == 'L') {
01451     while (1) {
01452       if (j + 3 > len) {
01453         break;
01454       } else if ((s[j] == '\\') && (s[j+1] == '.') && (s[j+2] == '.')
01455                  && ((j + 3 == len) || (s[j+3] == '\\'))) {
01456         pos = j + 3;
01457         j += 3;
01458       } else {
01459         break;
01460       }
01461     }
01462   }
01463 
01464   if (pos > 0) {
01465     if (pos == len) 
01466       *_lit_start = len;
01467     else if ((pos + 2 < len)
01468             && s[pos+1] == '\\') {
01469       *_lit_start = pos + 2;
01470     } else {
01471       *_lit_start = pos + 1;
01472     }
01473   } else if (len > 8) {
01474     if (s[8] == '\\')
01475       *_lit_start = 9;
01476     else
01477       *_lit_start = 8;
01478   } else
01479     *_lit_start = len;
01480 
01481   return pos;
01482 }
01483 
01484 static char *convert_to_backslashbackslash_qm(char *cleaned, int *_clen, char *str, int *_alloc, int len)
01485      /* cleaned (bad name) is input; str must be NULL or at least
01486        *_clen + 10; alloc is size of str; result maybe goes into str,
01487        but new srt may be returned, and result length is in
01488        *_clen. len is amount extract expected to be useful in str. */
01489 {
01490   int clen = *_clen, pos;
01491   int alloc = *_alloc;
01492 
01493   if (!str) {
01494     alloc = clen + 10;
01495     str = scheme_malloc_atomic(alloc);
01496   }
01497 
01498   {
01499     int cde = 0;
01500     if (!check_dos_slashslash_drive(cleaned, 0, clen, &cde, 0, 0))
01501       cde = 0;
01502     cleaned = remove_redundant_slashes(cleaned, &clen, cde, NULL, SCHEME_WINDOWS_PATH_KIND);
01503   }
01504   cleaned = do_normal_path_seps(cleaned, &clen, 0, 1, SCHEME_WINDOWS_PATH_KIND, NULL);
01505   if (scheme_is_relative_path(cleaned, clen, SCHEME_WINDOWS_PATH_KIND)) {
01506     memcpy(str, "\\\\?\\REL\\", 8);
01507     memcpy(str + 8, cleaned, clen);
01508     pos = clen + 8;
01509   } else {
01510     int plen, xdel = 0;
01511     if (cleaned[0] == '\\') {
01512       if (cleaned[1] == '\\') {
01513         /* UNC */
01514         xdel = 1;
01515         plen = 7;
01516         pos = 0; /* reset below */
01517       } else {
01518         /* Drive-relative absolute. */
01519         memcpy(str, "\\\\?\\RED\\", 8);
01520         memcpy(str + 8, cleaned, clen);
01521         pos = clen + 8;
01522         plen = 0;
01523       }
01524     } else {
01525       plen = 4;
01526       pos = 0; /* reset below */
01527     }
01528     if (plen) {
01529       memcpy(str, "\\\\?\\UNC", plen);
01530       memcpy(str + plen, cleaned + xdel, clen - xdel);
01531       pos = clen + plen - xdel;
01532     }
01533   }
01534 
01535   *_alloc = alloc;
01536   *_clen = pos;
01537   return str;
01538 }
01539 
01540 static char *get_drive_part(const char *wds, int wdlen)
01541 {
01542   int dend, dstart = 0;
01543   char *naya;
01544 
01545   if (check_dos_slashslash_qm(wds, wdlen, &dend, NULL, NULL)) {
01546     /* dend can't be < 0, because that's a relative path */
01547   } else if (!check_dos_slashslash_drive(wds, 0, wdlen, &dend, 0, 0))
01548     dend = 3;
01549 
01550   naya = scheme_malloc_atomic(dend + 1);
01551   memcpy(naya + dstart, wds, dend);
01552   naya[dend] = 0;
01553 
01554   return naya;
01555 }
01556 
01557 char *scheme_getdrive()
01558 {
01559   scheme_security_check_file("current-drive", NULL, SCHEME_GUARD_FILE_EXISTS);
01560 #ifdef DOS_FILE_SYSTEM
01561   {
01562     Scheme_Object *wd;
01563     wd = CURRENT_WD();
01564     return get_drive_part(SCHEME_PATH_VAL(wd), SCHEME_PATH_LEN(wd));
01565   }
01566 #else
01567   return "";
01568 #endif
01569 }
01570 
01571 char *strip_trailing_spaces(const char *s, int *_len, int delta, int in_place)
01572   /* Strips trailing dots, too */
01573 {
01574   int len, skip_end = 0;
01575 
01576   if (_len)
01577     len = *_len;
01578   else
01579     len = strlen(s);
01580 
01581   /* Keep separators that are at the very end: */
01582   if ((len - skip_end > delta) && IS_A_DOS_SEP(s[len - 1 - skip_end])) {
01583     skip_end++;
01584   }
01585 
01586   if ((len - skip_end > delta) 
01587       && ((s[len - 1 - skip_end] == ' ') || (s[len - 1 - skip_end] == '.'))) {
01588     char *t;
01589     int orig_len = len;
01590 
01591     while ((len - skip_end > delta) 
01592           && ((s[len - 1 - skip_end] == ' ') || (s[len - 1 - skip_end] == '.'))) {
01593       len--;
01594     }
01595 
01596     /* If the path element doesn't contain any non-space non-. chars, don't
01597        strip them after all. */
01598     if ((len - skip_end > delta) && !IS_A_DOS_SEP(s[len - 1 - skip_end])) {
01599       if (in_place)
01600        t = (char *)s;
01601       else {
01602        t = (char *)scheme_malloc_atomic(len + 1);
01603        memcpy(t, s, len - skip_end);
01604       }
01605       memcpy(t + len - skip_end, t + orig_len - skip_end, skip_end);
01606       t[len] = 0;
01607       
01608       if (_len)
01609        *_len = len;
01610       
01611       return t;
01612     }
01613   }
01614 
01615   return (char *)s;
01616 }
01617 
01618 /* Watch out for special device names. Could we do better than hardwiring this list? */
01619 static char *special_filenames[] = { "NUL", "CON", "PRN", "AUX", /* NT only: "CLOCK$", */
01620                                      "COM1", "COM2", "COM3", "COM4", "COM5", 
01621                                      "COM6", "COM7", "COM8", "COM9",
01622                                      "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", 
01623                                      "LPT6", "LPT7", "LPT8", "LPT9", NULL };
01624 
01625 static int is_special_filename(const char *f, int offset, int len, int not_nul, int immediate)
01626 {
01627   int i, j, delta;
01628 
01629   /* Skip over path: */
01630   if (!len)
01631     return 0;
01632   if (!immediate) {
01633     delta = len;
01634     if (check_dos_slashslash_qm(f, delta, NULL, NULL, NULL))
01635       return 0;
01636     delta -= 1;
01637     while (delta && !IS_A_DOS_SEP(f[delta])) {
01638       --delta;
01639     }
01640     if (!delta && is_drive_letter(f[0]) && f[1] == ':') {
01641       delta = 2;
01642     } else if (IS_A_DOS_SEP(f[delta]))
01643       delta++;
01644   } else
01645     delta = offset;
01646 
01647   for (i = not_nul; special_filenames[i]; i++) {
01648     const char *sf = special_filenames[i];
01649     for (j = 0; sf[j] && f[delta + j]; j++) {
01650       if (scheme_toupper((mzchar)(unsigned char)f[delta + j]) != sf[j])
01651        break;
01652     }
01653     if (j && !sf[j]) {
01654       j += delta;
01655       if ((j >= (len + offset))
01656          || (f[j] == '.')
01657          || (f[j] == ':'))
01658        return i + 1;
01659       while ((j < (len + offset))
01660             && ((f[j] == ' ')
01661                || (f[j] == '.'))) {
01662        j++;
01663       }
01664       if (j >= (len + offset))
01665        return i + 1;
01666 
01667       return 0;
01668     }
01669   }
01670 
01671   return 0;
01672 }
01673 
01674 #ifdef DOS_FILE_SYSTEM
01675 int scheme_is_special_filename(const char *f, int not_nul)
01676 {
01677   return is_special_filename(f, 0, strlen(f), not_nul, 0);
01678 }
01679 #endif
01680 
01681 static char *remove_redundant_slashes(char *filename, int *l, int delta, int *expanded, int kind)
01682 {
01683   int extra = 0, i, ilen = *l;
01684   
01685   for (i = ilen; --i > delta; ) {
01686     if (IS_A_SEP(kind, filename[i])) {
01687       if (IS_A_SEP(kind, filename[i - 1])) {
01688         extra++;
01689       }
01690     }
01691   }
01692 
01693   if (extra) {
01694     char *naya;
01695     naya = (char *)scheme_malloc_atomic(ilen + 1 - extra);
01696     extra = 0;
01697     for (i = delta; i < ilen; i++) {
01698       if (IS_A_SEP(kind, filename[i])
01699           && IS_A_SEP(kind, filename[i + 1])) {
01700         /* Skip */
01701         extra++;
01702       } else {
01703         naya[i - extra] = filename[i];
01704       }
01705     }
01706     memcpy(naya, filename, delta);
01707     ilen -= extra;
01708     naya[ilen] = 0;
01709     filename = naya;
01710     if (expanded)
01711       *expanded = 1;
01712   }
01713   
01714   *l = ilen;
01715   return filename;
01716 }
01717 
01718 static char *do_expand_filename(Scheme_Object *o, char* filename, int ilen, const char *errorin, 
01719                             int *expanded,
01720                             int report_bad_user, int fullpath,
01721                             int guards, int kind, int expand_user)
01722 {
01723   if (expanded)
01724     *expanded = 0;
01725 
01726   if (o) {
01727     o = TO_PATH(o);
01728     filename = SCHEME_PATH_VAL(o);
01729     ilen = SCHEME_PATH_LEN(o);
01730   }
01731 
01732   if (guards)
01733     scheme_security_check_file(errorin, filename, guards);
01734 
01735   if (ilen < 0)
01736     ilen = strlen(filename);
01737   else  {
01738     if (has_null(filename, ilen)) {
01739       if (errorin)
01740        raise_null_error(errorin, scheme_make_sized_path(filename, ilen, 1), "");
01741       else 
01742        return NULL;
01743     }
01744   }
01745 
01746   if (kind == SCHEME_UNIX_PATH_KIND) {
01747     /* User home lookup strategy taken from wxWindows: */
01748 
01749 #ifdef UNIX_FILE_SYSTEM
01750     if (expand_user && (filename[0] == '~')) {
01751       char user[256], *home = NULL, *naya;
01752       struct passwd *who = NULL;
01753       int u, f, len, flen;
01754     
01755       for (u = 0, f = 1; 
01756            u < 255 && filename[f] && filename[f] != '/'; 
01757            u++, f++) {
01758         user[u] = filename[f];
01759       }
01760 
01761       if (filename[f] && filename[f] != '/') {
01762         if (errorin && report_bad_user)
01763           scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
01764                            "%s: bad username in path: \"%q\"", 
01765                            errorin, filename);
01766         return NULL;
01767       }
01768       user[u] = 0;
01769 
01770       if (!user[0]) {
01771         if (!(home = getenv("HOME"))) {
01772           char *ptr;
01773 
01774           ptr = getenv("USER");
01775           if (!ptr)
01776             ptr = getenv("LOGNAME");
01777 
01778           who = ptr ? getpwnam(ptr) : NULL;
01779 
01780           if (!who)
01781             who = getpwuid(getuid());
01782         }
01783       } else
01784         who = getpwnam(user);
01785 
01786       if (!home && who)
01787         home = who->pw_dir;
01788 
01789       if (!home) {
01790         if (errorin && report_bad_user)
01791           scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
01792                            "%s: bad username in path: \"%q\"", 
01793                            errorin, filename);
01794         return NULL;
01795       }
01796 
01797       len = strlen(home);
01798       if (f < ilen) 
01799         flen = ilen - f - 1;
01800       else
01801         flen = 0;
01802       naya = (char *)scheme_malloc_atomic(len + flen + 2);
01803       memcpy(naya, home, len);
01804       naya[len] = '/';
01805       memcpy(naya + len + 1, filename + f + 1, flen);
01806       naya[len + flen + 1] = 0;
01807 
01808       if (expanded)
01809         *expanded = 1;
01810   
01811       filename = naya;
01812       ilen = len + flen + 1;
01813     }
01814 #endif
01815 
01816     /* Remove redundant slashes */
01817     {
01818       int l = ilen;
01819       filename = remove_redundant_slashes(filename, &l, 0, expanded, SCHEME_PLATFORM_PATH_KIND);
01820       ilen = l;
01821     }
01822   } else {
01823     /* SCHEME_WINDOWS_PATH_KIND */
01824     int drive_end, clean_start;
01825     int fixit = 0, i, insert_initial_sep = 0;
01826 
01827     if (!check_dos_slashslash_qm(filename, ilen, &drive_end, &clean_start, NULL))
01828       drive_end = 0;
01829     else if (drive_end < 0) {
01830       /* For \\?\REL\, only remove extra backslashes after 
01831         unprotected ..s, so count the start of that area
01832         as the drive end. */
01833       get_slashslash_qm_dot_ups_end(filename, ilen, &drive_end);
01834       /* Make sure that backslashes are doubled after dots. */
01835       if ((drive_end != ilen) && (filename[drive_end-2] != '\\')) {
01836        insert_initial_sep = 1;
01837        fixit = 1;
01838       }
01839     } else if (drive_end == 8) {
01840       /* For \\?\c:\\ path, start clean up after colon. */
01841       if (is_drive_letter(filename[4])
01842          && (filename[5] == ':'))
01843        drive_end = 6;
01844     } else if (drive_end == 9) {
01845       /* For \\?\\c:\\ path, start clean up after colon. */
01846       if ((filename[4] == '\\')
01847          && is_drive_letter(filename[5])
01848          && (filename[6] == ':'))
01849        drive_end = 7;
01850     } else {
01851       drive_end = clean_start;
01852     }
01853 
01854     /* Check whether to clean up the name, removing mulitple // and
01855        adding "/" after "c:" if necessary */
01856     if (!drive_end 
01857        && is_drive_letter(filename[0])
01858        && (filename[1] == ':') 
01859        && !IS_A_DOS_SEP(filename[2])) {
01860       drive_end = 2;
01861       insert_initial_sep = 1;
01862       fixit = 1;
01863     } else {
01864       int found_slash = 0, prim_only = drive_end;
01865       
01866       for (i = ilen; i-- > drive_end; ) {
01867        if (IS_A_DOS_X_SEP(prim_only, filename[i])) {
01868          if (IS_A_DOS_X_SEP(prim_only, filename[i - 1])) {
01869            if ((i > 1) || !found_slash)
01870              fixit = 1;
01871            break;
01872          }
01873          found_slash = 1;
01874        }
01875       }
01876     }
01877 
01878     if (fixit) {
01879       int pos, prim_only = drive_end;
01880       char *naya;
01881       
01882       if (expanded)
01883        *expanded = 1;
01884       
01885       if (!drive_end) {
01886        /* Allow // at start? */
01887        if (check_dos_slashslash_drive(filename, 0, ilen, NULL, 0, 0))
01888          drive_end = 2;
01889       }
01890 
01891       naya = (char *)scheme_malloc_atomic(ilen + 2);
01892 
01893       memcpy(naya, filename, drive_end);
01894       pos = i = drive_end;
01895       if (insert_initial_sep) {
01896        naya[pos++] = '\\';
01897       }
01898       
01899       while (i < ilen) {
01900        if (IS_A_DOS_X_SEP(prim_only, filename[i])
01901             && ((i + 1) < ilen)
01902            && IS_A_DOS_X_SEP(prim_only, filename[i + 1])) {
01903          i++;
01904        } else
01905          naya[pos++] = filename[i++];
01906       }
01907       
01908       naya[pos] = 0;
01909       filename = naya;
01910       ilen = pos;
01911 
01912       if (drive_end == 4) {
01913        /* If the root was \\?\, there's a chance that we removed a
01914           backslash and changed the root. In that case, add two \\s after \\?\: */
01915        check_dos_slashslash_qm(filename, ilen, &drive_end, NULL, NULL);
01916        if (drive_end != 4) {
01917          /* There's room to expand, because insert_initial_sep couldn't be -1. */
01918          if (filename[4] == '\\') {
01919            /* Need one more */
01920            memmove(filename + 5, filename + 4, ilen - 3);
01921            filename[4] = '\\'; /* Actually, this is redundant. */
01922            ilen += 1;
01923          } else {
01924            /* Need two more */
01925            memmove(filename + 6, filename + 4, ilen - 3);
01926            filename[4] = '\\'; /* Actually, this is redundant. */
01927            filename[5] = '\\';
01928            ilen += 2;
01929          }
01930        }
01931       }
01932     }
01933   }
01934 
01935   if (fullpath) {
01936     if (!scheme_is_complete_path(filename, ilen, kind)) {
01937       if (expanded)
01938        *expanded = 1;
01939       filename = do_path_to_complete_path(filename, ilen, NULL, 0, kind);
01940       ilen = strlen(filename);
01941     }
01942     if (kind == SCHEME_WINDOWS_PATH_KIND) {
01943       if (ilen > ((fullpath > 1) ? fullpath : 259)) {
01944         if (!check_dos_slashslash_qm(filename, ilen, NULL, NULL, NULL)) {
01945           /* Convert to \\?\ to avoid length limit. */
01946           int l = ilen, a = ilen + 1;
01947           Scheme_Object *p;
01948 
01949           p = scheme_make_sized_path(filename, ilen, 0);
01950           p = do_simplify_path(p, scheme_null, 0, 1, 0, SCHEME_WINDOWS_PATH_KIND);
01951           filename = SCHEME_PATH_VAL(p);
01952           ilen = SCHEME_PATH_LEN(p);
01953 
01954           filename = convert_to_backslashbackslash_qm(filename, &l, filename, &a, 0);
01955           filename[l] = 0;
01956         }
01957       }
01958     }
01959   }
01960 
01961   return filename;
01962 }
01963 
01964 char *scheme_expand_filename(char* filename, int ilen, const char *errorin, int *expanded, int guards)
01965 {
01966   return do_expand_filename(NULL, filename, ilen, errorin, expanded, 1, 1, guards, SCHEME_PLATFORM_PATH_KIND, 0);
01967 }
01968 
01969 char *scheme_expand_user_filename(char* filename, int ilen, const char *errorin, int *expanded, int guards)
01970 {
01971   return do_expand_filename(NULL, filename, ilen, errorin, expanded, 1, 1, guards, SCHEME_PLATFORM_PATH_KIND, 1);
01972 }
01973 
01974 char *scheme_expand_string_filename(Scheme_Object *o, const char *errorin, int *expanded, int guards)
01975 {
01976   return do_expand_filename(o, NULL, 0, errorin, expanded, 1, 1, guards, SCHEME_PLATFORM_PATH_KIND, 0);
01977 }
01978 
01979 #ifdef DOS_FILE_SYSTEM
01980 # define FIND_FIRST FindFirstFileW
01981 # define FIND_NEXT FindNextFileW
01982 # define FIND_CLOSE FindClose
01983 # define FF_TYPE WIN32_FIND_DATAW
01984 # define FF_HANDLE_TYPE HANDLE
01985 # define FIND_FAILED(h) (h == INVALID_HANDLE_VALUE)
01986 # define FF_A_RDONLY FILE_ATTRIBUTE_READONLY
01987 # define FF_A_DIR FILE_ATTRIBUTE_DIRECTORY
01988 # define GET_FF_ATTRIBS(fd) (fd.dwFileAttributes)
01989 # define GET_FF_MODDATE(fd) convert_date(&fd.ftLastWriteTime)
01990 # define GET_FF_NAME(fd) fd.cFileName
01991 static time_t convert_date(const FILETIME *ft)
01992 {
01993   LONGLONG l, delta;
01994   FILETIME ft2;
01995   SYSTEMTIME st;
01996   TIME_ZONE_INFORMATION tz;
01997 
01998   /* FindFirstFile incorrectly shifts for daylight saving. It
01999      subtracts an hour to get to UTC when daylight saving is in effect
02000      now, even when daylight saving was not in effect when the file
02001      was saved.  Counteract the difference. There's a race condition
02002      here, because we might cross the daylight-saving boundary between
02003      the time that FindFirstFile runs and GetTimeZoneInformation
02004      runs. Cross your fingers... */
02005   FileTimeToLocalFileTime(ft, &ft2);
02006   FileTimeToSystemTime(&ft2, &st);
02007   
02008   delta = 0;
02009   if (GetTimeZoneInformation(&tz) == TIME_ZONE_ID_DAYLIGHT) {
02010     /* Daylight saving is in effect now, so there may be a bad
02011        shift. Check the file's date. */
02012     int start_day_of_month, end_day_of_month, first_day_of_week, diff, end_shift;
02013 
02014     /* Valid only when the months match: */
02015     first_day_of_week = (st.wDayOfWeek - (st.wDay - 1 - (((st.wDay - 1) / 7) * 7)));
02016     if (first_day_of_week < 0)
02017       first_day_of_week += 7;
02018 
02019     diff = (tz.DaylightDate.wDayOfWeek - first_day_of_week);
02020     if (diff < 0)
02021       diff += 7;
02022     start_day_of_month = 1 + (((tz.DaylightDate.wDay - 1) * 7)
02023                            + diff);
02024        
02025     diff = (tz.StandardDate.wDayOfWeek - first_day_of_week);
02026     if (diff < 0)
02027       diff += 7;
02028     end_day_of_month = 1 + (((tz.StandardDate.wDay - 1) * 7)
02029                          + diff);
02030 
02031     /* Count ambigious range (when the clock goes back) as
02032        in standard time. We assume that subtracting the 
02033        ambiguous range does not go back into the previous day,
02034        and that the shift is a multiple of an hour. */
02035     end_shift = ((tz.StandardBias - tz.DaylightBias) / 60);
02036 
02037     if ((st.wMonth < tz.DaylightDate.wMonth)
02038        || ((st.wMonth == tz.DaylightDate.wMonth)
02039            && ((st.wDay < start_day_of_month)
02040               || ((st.wDay == start_day_of_month)
02041                   && (st.wHour < tz.DaylightDate.wHour))))) {
02042       /* Daylight saving had not yet started. */
02043       delta = ((tz.StandardBias - tz.DaylightBias) * 60);
02044     } else if ((st.wMonth > tz.StandardDate.wMonth)
02045               || ((st.wMonth == tz.StandardDate.wMonth)
02046                  && ((st.wDay > end_day_of_month)
02047                      || ((st.wDay == end_day_of_month)
02048                         && (st.wHour >= (tz.StandardDate.wHour
02049                                        - end_shift)))))) {
02050       /* Daylight saving was already over. */
02051       delta = ((tz.StandardBias - tz.DaylightBias) * 60);
02052     }
02053   }
02054 
02055   l = ((((LONGLONG)ft->dwHighDateTime << 32) | ft->dwLowDateTime)
02056        - (((LONGLONG)0x019DB1DE << 32) | 0xD53E8000));
02057   l /= 10000000;
02058   l += delta;
02059 
02060   return (time_t)l;
02061 }
02062 #endif
02063 
02064 #ifdef DOS_FILE_SYSTEM
02065 # define MZ_UNC_READ 0x1
02066 # define MZ_UNC_WRITE 0x2
02067 # define MZ_UNC_EXEC 0x4
02068 
02069 static int UNC_stat(char *dirname, int len, int *flags, int *isdir, Scheme_Object **date,
02070                   mzlonglong *filesize)
02071   /* dirname must be absolute */
02072 {
02073   /* Note: stat() doesn't work with UNC "drive" names or \\?\ paths.
02074      Also, stat() doesn't distinguish between the ability to
02075      list a directory's content and whether the directory exists. 
02076      So, we use GetFileAttributesExW(). */
02077   char *copy;
02078   WIN32_FILE_ATTRIBUTE_DATA fd;
02079   int must_be_dir = 0;
02080 
02081   if (isdir)
02082     *isdir = 0;
02083   if (date)
02084     *date = scheme_false;
02085 
02086   copy = scheme_malloc_atomic(len + 14);
02087   if (check_dos_slashslash_qm(dirname, len, NULL, NULL, NULL)) {
02088     memcpy(copy, dirname, len + 1);
02089   } else {
02090     memcpy(copy, dirname, len + 1);
02091     while (IS_A_DOS_SEP(copy[len - 1])) {
02092       --len;
02093       copy[len] = 0;
02094       must_be_dir = 1;
02095     }
02096   }
02097   /* If we ended up with "\\?\X:", then drop the "\\?\" */
02098   if ((copy[0] == '\\')&& (copy[1] == '\\') && (copy[2] == '?') && (copy[3] == '\\') 
02099       && is_drive_letter(copy[4]) && (copy[5] == ':') && !copy[6]) {
02100     memmove(copy, copy + 4, len - 4);
02101     len -= 4;
02102     copy[len] = 0;
02103   }
02104   /* If we ended up with "\\?\X:", then drop the "\\?\\" */
02105   if ((copy[0] == '\\') && (copy[1] == '\\') && (copy[2] == '?') && (copy[3] == '\\') 
02106       && (copy[4] == '\\') && is_drive_letter(copy[5]) && (copy[6] == ':') && !copy[7]) {
02107     memmove(copy, copy + 5, len - 5);
02108     len -= 5;
02109     copy[len] = 0;
02110   }
02111   if (!GetFileAttributesExW(WIDE_PATH(copy), GetFileExInfoStandard, &fd)) {
02112     errno = -1;
02113     return 0;
02114   } else {
02115     if (must_be_dir && !(GET_FF_ATTRIBS(fd) & FF_A_DIR))
02116       return 0;
02117     if (flags)
02118       *flags = MZ_UNC_READ | MZ_UNC_EXEC | ((GET_FF_ATTRIBS(fd) & FF_A_RDONLY) ? 0 : MZ_UNC_WRITE);
02119     if (date) {
02120       Scheme_Object *dt;
02121       time_t mdt;
02122       mdt = GET_FF_MODDATE(fd);
02123       dt = scheme_make_integer_value_from_time(mdt);
02124       *date = dt;
02125     }
02126     if (isdir) {
02127       *isdir = (GET_FF_ATTRIBS(fd) & FF_A_DIR);
02128     }
02129     if (filesize) {
02130       *filesize = ((mzlonglong)fd.nFileSizeHigh << 32) | fd.nFileSizeLow;
02131     }
02132     return 1;
02133   }
02134 }
02135 #endif
02136 
02137 int scheme_file_exists(char *filename)
02138 {
02139 # ifdef NO_STAT_PROC
02140   FILE *fp;
02141 
02142   fp = fopen(filename, "r");
02143   if (fp) {
02144     fclose(fp);
02145     return 1;
02146   } else
02147     return 0;
02148 # else
02149 #  ifdef DOS_FILE_SYSTEM
02150   /* Claim that all special files exist: */
02151   if (scheme_is_special_filename(filename, 0))
02152     return 1;
02153 
02154   {
02155     int isdir;
02156     return (UNC_stat(filename, strlen(filename), NULL, &isdir, NULL, NULL)
02157            && !isdir);
02158   }
02159 #  else
02160   struct MSC_IZE(stat) buf;
02161   int ok;
02162 
02163   do {
02164     ok = MSC_W_IZE(stat)(MSC_WIDE_PATH(filename), &buf);
02165   } while ((ok == -1) && (errno == EINTR));
02166 
02167   return !ok && !S_ISDIR(buf.st_mode);
02168 #  endif
02169 # endif
02170 }
02171 
02172 int scheme_directory_exists(char *dirname)
02173 {
02174 # ifdef NO_STAT_PROC
02175   return 0;
02176 # else
02177 #  ifdef DOS_FILE_SYSTEM
02178   int isdir;
02179 
02180   return (UNC_stat(dirname, strlen(dirname), NULL, &isdir, NULL, NULL)
02181          && isdir);
02182 #  else
02183   struct MSC_IZE(stat) buf;
02184 
02185   while (1) {
02186     if (!MSC_IZE(stat)(dirname, &buf))
02187       break;
02188     else if (errno != EINTR)
02189       return 0;
02190   }
02191 
02192   return S_ISDIR(buf.st_mode);
02193 #  endif
02194 # endif
02195 }
02196 
02197 int scheme_is_regular_file(char *filename)
02198 {
02199 # ifdef NO_STAT_PROC
02200   return 0;
02201 # else
02202   struct MSC_IZE(stat) buf;
02203 
02204 #  ifdef DOS_FILE_SYSTEM
02205   if (scheme_is_special_filename(filename, 1))
02206     return 0;
02207 #  endif
02208 
02209   while (1) {
02210     if (!MSC_W_IZE(stat)(MSC_WIDE_PATH(filename), &buf))
02211       break;
02212     else if (errno != EINTR)
02213       return 0;
02214   }
02215 
02216   return S_ISREG(buf.st_mode);
02217 # endif  
02218 }
02219 
02220 static Scheme_Object *file_exists(int argc, Scheme_Object **argv)
02221 {
02222   char *f;
02223 
02224   if (!SCHEME_PATH_STRINGP(argv[0]))
02225     scheme_wrong_type("file-exists?", SCHEME_PATH_STRING_STR, 0, argc, argv);
02226 
02227   f = do_expand_filename(argv[0],
02228                       NULL,
02229                       0,
02230                       "file-exists?",
02231                       NULL,
02232                       0, 1,
02233                       SCHEME_GUARD_FILE_EXISTS,
02234                          SCHEME_PLATFORM_PATH_KIND,
02235                          0);
02236 
02237   return (f && scheme_file_exists(f)) ? scheme_true : scheme_false;
02238 }
02239 
02240 static Scheme_Object *directory_exists(int argc, Scheme_Object **argv)
02241 {
02242   char *f;
02243 
02244   if (!SCHEME_PATH_STRINGP(argv[0]))
02245     scheme_wrong_type("directory-exists?", SCHEME_PATH_STRING_STR, 0, argc, argv);
02246 
02247   f = do_expand_filename(argv[0],
02248                       NULL,
02249                       0,
02250                       "directory-exists?",
02251                       NULL,
02252                       0, 1,
02253                       SCHEME_GUARD_FILE_EXISTS,
02254                          SCHEME_PLATFORM_PATH_KIND,
02255                          0);
02256 
02257   return (f && scheme_directory_exists(f)) ? scheme_true : scheme_false;
02258 }
02259 
02260 static Scheme_Object *link_exists(int argc, Scheme_Object **argv)
02261 {
02262   char *filename;
02263 #ifndef UNIX_FILE_SYSTEM
02264   Scheme_Object *bs;
02265 #endif
02266 
02267   if (!SCHEME_PATH_STRINGP(argv[0]))
02268     scheme_wrong_type("link-exists?", SCHEME_PATH_STRING_STR, 0, argc, argv);
02269 
02270 
02271 #ifndef UNIX_FILE_SYSTEM
02272   /* DOS or MAC: expand isn't called, so check the form now */
02273   bs = TO_PATH(argv[0]);
02274   filename = SCHEME_PATH_VAL(bs);
02275   if (has_null(filename, SCHEME_PATH_LEN(bs))) {
02276     raise_null_error("link-exists?", bs, "");
02277     return NULL;
02278   }
02279 #endif
02280 
02281 #ifdef DOS_FILE_SYSTEM
02282   scheme_security_check_file("link-exists?", filename, SCHEME_GUARD_FILE_EXISTS);
02283 
02284   return scheme_false;
02285 #endif
02286 #ifdef UNIX_FILE_SYSTEM
02287   {
02288     struct MSC_IZE(stat) buf;
02289 
02290     filename = do_expand_filename(argv[0],
02291                               NULL,
02292                               0,
02293                               "link-exists?",
02294                               NULL,
02295                               0, 1,
02296                               SCHEME_GUARD_FILE_EXISTS, 
02297                                   SCHEME_PLATFORM_PATH_KIND,
02298                                   0);
02299     while (1) {
02300       if (!MSC_W_IZE(lstat)(MSC_WIDE_PATH(filename), &buf))
02301        break;
02302       else if (errno != EINTR)
02303        return scheme_false;
02304     }
02305 
02306     if (S_ISLNK(buf.st_mode))
02307       return scheme_true;
02308     else
02309       return scheme_false;
02310   }
02311 #endif
02312 }
02313 
02314 Scheme_Object *scheme_get_fd_identity(Scheme_Object *port, long fd)
02315 {
02316   int errid = 0;
02317   unsigned long devi = 0, inoi = 0, inoi2 = 0;
02318   int shift = 0, shift2 = -1;
02319   Scheme_Object *devn, *inon, *a[2];
02320 
02321 #ifdef FILES_HAVE_FDS
02322   struct MSC_IZE(stat) buf;
02323 
02324   while (1) {
02325     if (!MSC_IZE(fstat)(fd, &buf))
02326       break;
02327     else if (errno != EINTR) {
02328       errid = errno;
02329       break;
02330     }
02331   }
02332   
02333   if (!errid) {
02334     /* Warning: we assume that dev_t and ino_t fit in a long. */
02335     devi = (unsigned long)buf.st_dev;
02336     inoi = (unsigned long)buf.st_ino;
02337     shift = sizeof(dev_t);
02338   }
02339 #endif
02340 #ifdef WINDOWS_FILE_HANDLES
02341   BY_HANDLE_FILE_INFORMATION info;
02342 
02343   if (GetFileInformationByHandle((HANDLE)fd, &info))
02344     errid = 0;
02345   else
02346     errid = GetLastError();
02347 
02348   if (!errid) {
02349     devi = info.dwVolumeSerialNumber;
02350     inoi = info.nFileIndexLow;
02351     inoi2 = info.nFileIndexHigh;
02352     shift = sizeof(DWORD);
02353     shift2 = 2 * sizeof(DWORD);
02354   }
02355 #endif
02356 
02357   if (!errid) {
02358     devn = scheme_make_integer_value_from_unsigned(devi);
02359     inon = scheme_make_integer_value_from_unsigned(inoi);
02360     
02361     a[0] = inon;
02362     a[1] = scheme_make_integer(shift);
02363     inon = scheme_bitwise_shift(2, a);
02364     
02365     if (shift2 > -1) {
02366       a[0] = scheme_make_integer_value_from_unsigned(inoi2);
02367       a[1] = scheme_make_integer(shift2);
02368       inon = scheme_bin_plus(inon, scheme_bitwise_shift(2, a));
02369     }
02370 
02371     return scheme_bin_plus(devn, inon);
02372   }
02373 
02374   scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
02375                  "port-file-identity: error obtaining identity (%E)",
02376                  errid);
02377   return NULL;
02378 }
02379 
02380 static int path_is_simple_dir_without_sep(Scheme_Object *path)
02381 {
02382   int len;
02383 
02384   len = SCHEME_PATH_LEN(path);
02385   if (IS_A_SEP(SCHEME_PATH_VAL(path)[len - 1], SCHEME_PATH_KIND(path)))
02386     return 0;
02387 
02388   /* The simple thing to do here is to use split_path, but that's
02389      a lot of extra computation. */
02390 
02391   if (SCHEME_PATH_VAL(path)[len - 1] == '.') {
02392     if (len == 1)
02393       return 1;
02394     if (IS_A_SEP(SCHEME_PATH_VAL(path)[len - 2], SCHEME_PATH_KIND(path)))
02395       return 1;
02396     if (SCHEME_PATH_VAL(path)[len - 2] == '.') {
02397       if (len == 2)
02398         return 1;
02399       if (IS_A_SEP(SCHEME_PATH_VAL(path)[len - 3], SCHEME_PATH_KIND(path)))
02400         return 1;
02401     }
02402   }
02403 
02404 #ifdef TILDE_IS_ABSOLUTE
02405   if (SCHEME_PATH_KIND(path) == SCHEME_UNIX_PATH_KIND) {
02406     if (SCHEME_PATH_VAL(path)[0] == '~') {
02407       int i;
02408       for (i = 1; i < len; i++) {
02409         if (IS_A_UNIX_SEP(SCHEME_PATH_VAL(path)[i]))
02410           break;
02411       }
02412       if (i == len)
02413         return 1;
02414     }
02415   }
02416 #endif
02417 
02418   if (SCHEME_PATH_KIND(path) == SCHEME_WINDOWS_PATH_KIND) {
02419     int drive_end;
02420     if (check_dos_slashslash_drive(SCHEME_PATH_VAL(path), 0, len, &drive_end, 1, 0))
02421       return 1; /* exactly a UNC drive */
02422     if (len == 2
02423         && (is_drive_letter(SCHEME_PATH_VAL(path)[0]))
02424         && (SCHEME_PATH_VAL(path)[1] == ':'))
02425       return 1; /* a c: path */
02426   }
02427 
02428   return 0;
02429 }
02430 
02431 static Scheme_Object *do_path_to_directory_path(char *s, long offset, long len, Scheme_Object *p, int just_check,
02432                                                 int kind)
02433 /* Although this function accepts an offset, the Windows part assumes that
02434    `offset' is always 0. */
02435 {
02436   char *s2;
02437   int not_a_sep = 0;
02438 
02439   if (kind == SCHEME_WINDOWS_PATH_KIND) {
02440     int slash_dir_sep = 1;
02441 
02442     {
02443       int drive_end;
02444 
02445       if (offset) {
02446         scheme_signal_error("path->directory-path currently assumes a 0 offset");
02447       }
02448 
02449       if (check_dos_slashslash_qm(s, len, &drive_end, NULL, NULL)) {
02450 #if DROP_REDUNDANT_SLASHES
02451         if (drive_end < 0) {
02452           /* It's a \\?\REL\ or \\?\RED\ path. */
02453           int litpos;
02454           drive_end = get_slashslash_qm_dot_ups_end(s, len, &litpos);
02455           /* If there's no path after the ..s, then nothing more is needed. */
02456           if (litpos >= len)
02457             return p;
02458         } else {
02459           /* If s is just a drive, then nothing more is needed. */
02460           if (drive_end == len)
02461             return p;
02462         }
02463 #endif
02464 
02465         /* In \\?\, / can be part of a name, and it is never a separator. */
02466         slash_dir_sep = 0;
02467         /* Any "." or ".." at the end is a literal path element,
02468            not an up- or same-directory indicator: */
02469         not_a_sep = 1;
02470       } else {
02471 #if DROP_REDUNDANT_SLASHES
02472         /* A slash after C: is not strictly necessary: */
02473         if ((len == 2)
02474             && is_drive_letter(s[offset])
02475             && (s[offset+1] == ':'))
02476           return p;
02477 #endif
02478       }
02479     }
02480     {
02481       int cs = s[offset + len - 1];
02482       if (slash_dir_sep ? IS_A_DOS_SEP(cs) : (cs == '\\'))
02483         return p;
02484     }
02485   } else {
02486     if (IS_A_UNIX_SEP(s[offset + len - 1]))
02487       return p;
02488   }
02489 
02490 #if DROP_REDUNDANT_SLASHES
02491   if (!not_a_sep
02492       && (((len > 1) && (s[offset + len - 1] == '.') && IS_A_SEP(kind, s[offset + len - 2]))
02493           || ((len == 1) && (s[offset] == '.'))))
02494     return p;
02495   if (!not_a_sep
02496       && (((len > 2) 
02497            && (s[offset + len - 1] == '.') 
02498            && (s[offset + len - 2] == '.') 
02499            && IS_A_SEP(kind, s[offset + len - 3]))
02500           || ((len == 2) && (s[offset] == '.') && (s[offset + 1] == '.'))))
02501     return p;
02502   
02503 # ifdef TILDE_IS_ABSOLUTE
02504   if (kind == SCHEME_UNIX_PATH_KIND) {
02505     if (s[offset] == '~') {
02506       long i;
02507       for (i = 1; i < len; i++) {
02508         if (IS_A_UNIX_SEP(s[offset + i]))
02509           break;
02510       }
02511       if (i >= len)
02512         return p;
02513     }
02514   }
02515 # endif
02516 #endif
02517 
02518   if (just_check)
02519     return NULL;
02520 
02521   s2 = (char *)scheme_malloc_atomic(len + 2);
02522   memcpy(s2, s XFORM_OK_PLUS offset, len);
02523   s2[len] = FN_SEP(kind);
02524   s2[len+1] = 0;
02525 
02526   return scheme_make_sized_offset_kind_path(s2, 0, len + 1, 0, kind);
02527 }
02528 
02529 Scheme_Object *scheme_path_to_directory_path(Scheme_Object *p)
02530 {
02531   return do_path_to_directory_path(SCHEME_PATH_VAL(p), 0, SCHEME_PATH_LEN(p), p, 0, 
02532                                    SCHEME_PATH_KIND(p));
02533 }
02534 
02535 static char *do_normal_path_seps(char *si, int *_len, int delta, int strip_trail, int kind, int *_did)
02536 {
02537   if (kind == SCHEME_UNIX_PATH_KIND) {
02538     return si;
02539   } else {
02540     int i;
02541     unsigned char *s;
02542     int len = *_len;
02543     
02544     if (kind == SCHEME_WINDOWS_PATH_KIND) {
02545       if (!delta && check_dos_slashslash_qm(si, len, NULL, NULL, NULL))
02546         return si;
02547     }
02548     
02549     s = (unsigned char *)MALLOC_N_ATOMIC(char, len + 1);
02550     memcpy(s, si, len + 1);
02551     
02552     if (kind == SCHEME_WINDOWS_PATH_KIND) {
02553       for (i = delta; i < len; i++) {
02554         if (s[i] == '/') {
02555           if (_did)
02556             *_did = 1;
02557           s[i] = '\\';
02558         }
02559       }
02560       if (strip_trail)
02561         s = (unsigned char *)strip_trailing_spaces((char *)s, _len, delta, 1);
02562     }
02563     
02564     return (char *)s;
02565   }
02566 }
02567 
02568 char *scheme_normal_path_seps(char *si, int *_len, int delta)
02569 {
02570   return do_normal_path_seps(si, _len, delta, 1, SCHEME_PLATFORM_PATH_KIND, NULL);
02571 }
02572 
02573 #define PATH_EXTRA_SPACE 4
02574 
02575 static Scheme_Object *do_build_path(int argc, Scheme_Object **argv, int idelta, int no_final_simplify, int kind)
02576 /* Originally, it made sense to just perform build operations
02577    directly on string representations, because it was simple enough.
02578    Over the years, though, as we refined the path syntax for Windows
02579    to deal with all of its idiosyncracies, this has gotten completely 
02580    out of hand. */
02581 {
02582 #define PN_BUF_LEN 256
02583   int pos, i, len, no_sep;
02584   int alloc = PN_BUF_LEN;
02585   char buffer[PN_BUF_LEN], *str, *next;
02586   int rel, next_off;
02587   int first_was_drive = 0;
02588   int first_len = 0;
02589   int needs_extra_slash = 0;
02590   int pre_unc = 0;
02591   int pre_qm = 0;
02592   const char *who = (idelta ? "build-path/convention-type" : "build-path");
02593 
02594   str = buffer;
02595   pos = 0;
02596 
02597   no_sep = 0; /* This is actually initialized after we know whether
02598                it's relative or not. */
02599 
02600   for (i = 0 ; i < argc; i++) {
02601     if (SCHEME_GENERAL_PATH_STRINGP(argv[i+idelta])
02602        || (SCHEME_SYMBOLP(argv[i+idelta]) 
02603            && (SAME_OBJ(argv[i+idelta], up_symbol)
02604               || SAME_OBJ(argv[i+idelta], same_symbol)))) {
02605       next_off = 0;
02606       if (SAME_OBJ(argv[i+idelta], up_symbol)) {
02607         next = "..";
02608         len = 2;
02609       } else if (SAME_OBJ(argv[i+idelta], same_symbol)) {
02610        next = ".";
02611        len = 1;
02612       } else {
02613        Scheme_Object *bs;
02614 
02615         if (SCHEME_CHAR_STRINGP(argv[i+idelta])) {
02616           if (kind != SCHEME_PLATFORM_PATH_KIND) {
02617             scheme_arg_mismatch(who,
02618                                 (idelta
02619                                  ? "specified convention incompatible with string path element: "
02620                                  : "preceding path's convention incompatible with string path element: "),
02621                                 argv[i+idelta]); 
02622           }
02623         }
02624 
02625        bs = TO_PATH(argv[i+idelta]);
02626 
02627         if (kind != SCHEME_PATH_KIND(bs)) {
02628           scheme_arg_mismatch(who,
02629                               (idelta
02630                                ? "specified convention incompatible with given path element: "
02631                                : "preceding path's convention incompatible from given path element: "),
02632                               argv[i+idelta]);
02633         }
02634 
02635        next = SCHEME_PATH_VAL(bs);
02636        len = SCHEME_PATH_LEN(bs);
02637        if (!len) {
02638          char *astr;
02639          long alen;
02640 
02641          astr = scheme_make_args_string("other ", i+idelta, argc, argv, &alen);
02642          scheme_raise_exn(MZEXN_FAIL_CONTRACT,
02643                         "%s: %d%s path element is an empty string%t", 
02644                            who,
02645                         i + 1,
02646                         scheme_number_suffix(i + 1),
02647                         astr, alen); 
02648          return scheme_false;
02649        }
02650 
02651        if (has_null(next, len)) {
02652          raise_null_error(who, argv[i+idelta], " element");
02653          return NULL;
02654        }
02655       }
02656 
02657       if (kind == SCHEME_WINDOWS_PATH_KIND) {
02658        /* Strip trailing spaces before we add more path parts,
02659           because trailing spaces originally don't count for the base
02660           path, and they'll start counting if we add more without
02661           removing the spaces first. first_len points after anything
02662           that should be saved due to a \\?\ prefix. */
02663        int p = pos;
02664        strip_trailing_spaces(str, &p, first_len, 1);
02665        pos = p;
02666       }
02667 
02668       /* +3: null term, leading sep, and trailing sep (if up & Mac) */
02669       if (pos + len + PATH_EXTRA_SPACE >= alloc) {
02670        char *naya;
02671        int newalloc;
02672 
02673        newalloc = 2 * alloc + len + 1;
02674        naya = (char *)scheme_malloc_atomic(newalloc);
02675        memcpy(naya, str, pos);
02676        alloc = newalloc;
02677        
02678        str = naya;
02679       }
02680 
02681       if (kind == SCHEME_UNIX_PATH_KIND) {
02682         if (next[0] == '/') {
02683           rel = 0;
02684           if (i) {
02685             scheme_raise_exn(MZEXN_FAIL_CONTRACT,
02686                              "%s: absolute path \"%q\" cannot be"
02687                              " added to a path",
02688                              who,
02689                              next);
02690             return scheme_false;
02691           }
02692         } else {
02693           rel = 1;
02694 #ifdef TILDE_IS_ABSOLUTE
02695           if (i && (next[0] == '.') && (next[1] == '/') && (next[2] == '~')) {
02696             /* Strip the "./" prefix */
02697             next_off += 2;
02698             len -= 2;
02699           }
02700 #endif
02701         }
02702       } else {
02703         /* SCHEME_WINDOWS_PATH_KIND: */
02704        int is_drive;
02705 
02706        needs_extra_slash = 0;
02707        
02708        if (IS_A_DOS_SEP(next[0])) {
02709          int drive_end, plus_sep = 0;
02710          rel = 0;
02711          if (check_dos_slashslash_qm(next, len, &drive_end, NULL, &plus_sep)) {
02712            if (drive_end < 0) {
02713              /* \\?\REL\ or \\?\RED\ path */
02714              rel = 1;
02715              is_drive = 0;
02716              if (i) {
02717               int dots_end, lit_start;
02718               int new_rel_base, need_simplify;
02719               int base_is_here = 0;
02720 
02721               /* If the current base is not a \\?\ path, turn it into one. */
02722               if (!check_dos_slashslash_qm(str, pos, &drive_end, NULL, NULL)) {
02723                 Scheme_Object *simp;
02724 
02725                 str[pos] = 0;
02726                 simp = do_simplify_path(scheme_make_sized_offset_kind_path(str, 0, pos, 0,
02727                                                                              SCHEME_WINDOWS_PATH_KIND),
02728                                      scheme_null, first_len, 0, 0,
02729                                           SCHEME_WINDOWS_PATH_KIND);
02730                 if (SCHEME_FALSEP(simp)) {
02731                   /* Base path is just relative "here". We can ignore it. */
02732                   pos = 0;
02733                   first_len = len;
02734                   if (next[len] != '\\')
02735                     first_len++;
02736                   no_sep = 1;
02737                   new_rel_base = 0;
02738                 } else {
02739                   char *cleaned;
02740                   int clen;
02741                   int al = alloc;
02742 
02743                   clen = SCHEME_PATH_LEN(simp); 
02744                   cleaned = SCHEME_PATH_VAL(simp);
02745 
02746                   str = convert_to_backslashbackslash_qm(cleaned, &clen, str, &al, 
02747                                                     len + PATH_EXTRA_SPACE);
02748 
02749                   pos = clen;
02750                   alloc = al;
02751                   
02752                   if ((pos > 5)
02753                      && (str[4] == 'R')
02754                      && (str[5] == 'E'))
02755                     new_rel_base = 1;
02756                   else
02757                     new_rel_base = 0;
02758 
02759                   if (str[pos - 1] != '\\')
02760                     str[pos++] = '\\';
02761                   no_sep = 1;
02762                   first_len = pos;
02763                 }
02764                 need_simplify = 0;
02765               } else {
02766                 new_rel_base = (drive_end < 0);
02767                 need_simplify = 1;
02768               }
02769               
02770               if (!pos) {
02771                 /* Base was relative "here", so we can use next directly */
02772               } else {
02773                 dots_end = get_slashslash_qm_dot_ups_end(next, len, &lit_start);
02774                 
02775                 if (dots_end > 0) {
02776                   /* Add dots part of this addition, then simplify again: */
02777                   if (!no_sep)
02778                     str[pos++] = '\\';
02779                   memcpy(str + pos, next + 8, dots_end - 8);
02780                   pos += dots_end - 8;
02781                   str[pos] = 0;
02782                   need_simplify = 1;
02783                 }
02784 
02785                 if (need_simplify) {
02786                     /* Simplify the base path to build on: */
02787                   Scheme_Object *simp;
02788 
02789                   simp = do_simplify_path(scheme_make_sized_offset_kind_path(str, 0, pos, 0,
02790                                                                                SCHEME_WINDOWS_PATH_KIND),
02791                                        scheme_null, first_len, 0, 1,
02792                                             SCHEME_WINDOWS_PATH_KIND);
02793                   if (SCHEME_FALSEP(simp)) {
02794                       /* Note: if root turns out to be relative, then we couldn't
02795                          have had a \\?\RED\ path. */
02796                     memcpy(str, "\\\\?\\REL\\\\", 9);
02797                     pos = 9;
02798                     no_sep = 1;
02799                     base_is_here = 1;
02800                   } else {
02801                     pos = SCHEME_PATH_LEN(simp);
02802                     memcpy(str, SCHEME_PATH_VAL(simp), pos);
02803                     no_sep = (str[pos - 1] == '\\');
02804                   }
02805                 }
02806 
02807                 /* At this point, we may have dots only in a \\?\REL
02808                    path in str, or we might have something without a 
02809                    \\ to prevent later .. from being parsed as 'up.
02810                    So, add a backslash if needed. */
02811                 if (new_rel_base && (lit_start < len)) {
02812                   int ls;
02813                   dots_end = get_slashslash_qm_dot_ups_end(str, pos, &ls);
02814                   if (dots_end > 0) {
02815                     if (ls == pos) {
02816                      if (dots_end + 2 > pos) {
02817                        if (dots_end + 1 > pos)
02818                          str[pos++] = '\\';
02819                        str[pos++] = '\\';
02820                        no_sep = 1;
02821                      }
02822                     }
02823                   } else if (ls == 8) {
02824                     memmove(str + 9, str + 8, pos - 8);
02825                     str[8] = '\\';
02826                     pos++;
02827                     no_sep = 1;
02828                   } 
02829                 }
02830 
02831                 /* Set offset into next to get only literal part, and
02832                    set first_len to indicate that the result will be
02833                    literal */
02834                 next_off = lit_start;
02835                 len -= next_off;
02836                 if (!len) {
02837                   if (base_is_here) {
02838                     /* Special case: base is "here" and path to add is
02839                       "here". Make sure result is just ".". */
02840                     pos = 0;
02841                     no_sep = 1;
02842                     next = ".";
02843                     len = 1;
02844                     next_off = 0;
02845                   } else
02846                     no_sep = 1;
02847                 } else {
02848                   /* One last possibility: str is \\?\ (which counts as a bizaare
02849                      root). We need two extra slashes. */
02850                   if (!new_rel_base && (pos == 4)) {
02851                     str[pos++] = '\\';
02852                     str[pos++] = '\\';
02853                   }
02854                 }
02855                 first_len = pos + len;
02856                 if (next[next_off + len] != '\\')
02857                   first_len++;
02858               }
02859              } else {
02860               first_len = len;
02861              }
02862            } else {
02863              /* non-REL/RED \\?\ path */
02864               is_drive = (drive_end == len);
02865              needs_extra_slash = plus_sep;
02866              if (!i) {
02867               first_len = len;
02868               if (next[first_len - 1] != '\\')
02869                 first_len++;
02870              }
02871            }
02872          } else
02873            is_drive = check_dos_slashslash_drive(next, 0, len, NULL, 1, 0);
02874        } else if ((len >= 2) 
02875                  && is_drive_letter(next[0])
02876                  && (next[1] == ':')) {
02877          int j;
02878          rel = 0;
02879          for (j = 2; j < len; j++) {
02880            if (!IS_A_DOS_SEP(next[j]))
02881              break;
02882          }
02883          is_drive = (j >= len);
02884        } else {
02885          rel = 1;
02886          is_drive = 0;
02887        }
02888 
02889        if (!rel) {
02890          if (i && (!first_was_drive || (i > 1) || is_drive)) {
02891            if (pos > 30) {
02892              str[27] = '.';
02893              str[28] = '.';
02894              str[29] = '.';
02895              str[30] = 0;
02896            } else
02897              str[pos] = 0;
02898            scheme_raise_exn(MZEXN_FAIL_CONTRACT,
02899                           "%s: %s \"%s\" cannot be"
02900                           " added to the path \"%q\"",
02901                              who,
02902                           is_drive ? "drive" : "absolute path",
02903                           next, str);
02904            return scheme_false;
02905          }
02906 
02907          if (i == 1) {
02908            /* Absolute path onto a drive: skip separator(s) */
02909            while (len && IS_A_DOS_SEP(next[next_off])) {
02910              next_off++;
02911              len--;
02912            }
02913          }
02914        }
02915 
02916        if (!i)
02917          first_was_drive = is_drive;
02918       }
02919 
02920       if (!i) {
02921        no_sep = 1;
02922       }
02923       
02924       if (kind == SCHEME_WINDOWS_PATH_KIND) {
02925         if (i) {
02926           pre_unc = check_dos_slashslash_drive(str, 0, pos, NULL, 0, 0);
02927          if (!pre_unc) {
02928            int de;
02929            if (check_dos_slashslash_qm(str, pos, &de, NULL, NULL)) {
02930              if (de == 4) /* \\?\ */
02931               pre_qm = 1;
02932            }
02933          } else
02934            pre_qm = 0;
02935         } else {
02936           pre_unc = 1;
02937          pre_qm = 0;
02938        }
02939 
02940         if (no_final_simplify
02941             && (len == 2) 
02942             && (next[next_off] == '.')
02943             && (next[next_off+1] == '.')
02944             && (first_len < pos + 2)) {
02945           /* Adding ".." ... */
02946           int de;
02947           if (check_dos_slashslash_qm(str, pos, &de, NULL, NULL)) {
02948             if (de < 0) {
02949               /* ... to a \\?\REL\ or \\?\RED\ path. Unless the \\?\REL\ path
02950                  is only dots, we need to remove a path element
02951                  here, instead of waiting for simplify, because simplify
02952                  will just push the job back here. */
02953               int ls, dots_end;
02954               dots_end = get_slashslash_qm_dot_ups_end(str, pos, &ls);
02955               if (ls == pos) {
02956                 /* It's ok to add "..". Make sure we don't
02957                    append to "..\\" by setting pos to no more
02958                    than dots_end + 1. */
02959                 if (dots_end < ls)
02960                   pos = dots_end + 1;
02961               } else {
02962                 int q;
02963                 for (q = pos; q-- > ls; ) {
02964                   if (str[q] == '\\') {
02965                     break;
02966                   }
02967                 }
02968                 pos = q;
02969                 first_len = pos;
02970                 len = 0;
02971                 while (q && (str[q-1] == '\\')) {
02972                   q--;
02973                 }
02974                 if (q == 7) {
02975                   /* All we have left is \\?\REL or \\?\RED (plus a slash or two).
02976                      We should only get here when called by scheme_simplify. */
02977                   if (i + 1 == argc) {
02978                     /* Since we were called by scheme_simplify, use #f to mean
02979                        the empty path. */
02980                     return scheme_false;
02981                   }
02982                   /* Shouldn't ever get here, but just in case... */
02983                   str[0] = '.';
02984                   pos = 1;
02985                   no_sep = 1;
02986                   first_len = 0;
02987                 }
02988               }
02989             }
02990           }
02991         }
02992       }
02993 
02994       if (!no_sep)
02995        str[pos++] = FN_SEP(kind);
02996 
02997       memcpy(str + pos, next + next_off, len);
02998       pos += len;
02999 
03000       if (kind == SCHEME_WINDOWS_PATH_KIND) {
03001         if (!pre_unc
03002             && check_dos_slashslash_drive(str, 0, pos, NULL, 0, 0)) {
03003           /* Added to //x to get something that looks like UNC. Remove the
03004              first [back]slash. */
03005           memmove(str, str+1, pos - 1);
03006           --pos;
03007         }
03008        if (pre_qm) {
03009          int de;
03010 
03011          /* Normalize path separators for the addition: */
03012          {
03013            int i;
03014            for (i = first_len; i < pos; i++) {
03015              if (str[i] == '/') {
03016               str[i] = '\\';
03017              }
03018            }
03019          }
03020 
03021          /* check the \\?\ parsing */
03022          check_dos_slashslash_qm(str, pos, &de, NULL, NULL);
03023          if (de != 4) {
03024            /* Added to \\?\ to get something that now looks like 
03025               a \\?\UNC path. Insert a backslash or two. */
03026            int amt = ((str[4] == '\\') ? 1 : 2);
03027        
03028            if (pos + amt >= alloc) {
03029              char *naya;
03030              int newalloc;
03031              
03032              newalloc = 2 * alloc;
03033              naya = (char *)scheme_malloc_atomic(newalloc);
03034              memcpy(naya, str, pos);
03035              alloc = newalloc;
03036              
03037              str = naya;
03038            }
03039            memmove(str + 4 + amt, str + 4, pos - 4);
03040            str[4] = '\\';
03041            if (amt == 2)
03042              str[5] = '\\';
03043            pos += amt;
03044            first_len += amt;
03045          }
03046        }
03047 
03048         if (needs_extra_slash) {
03049           if (needs_extra_slash >= pos)
03050             str[pos++] = '\\';
03051           else if (str[needs_extra_slash] != '\\') {
03052             memmove(str + needs_extra_slash + 1, str + needs_extra_slash, pos - needs_extra_slash);
03053             str[needs_extra_slash] = '\\';
03054             pos++;
03055           }
03056         }
03057       }
03058 
03059       /* If last path elem ends in a separator, don't add one: */
03060       if (len) {
03061        no_sep = IS_A_SEP(kind, next[next_off + len - 1]);
03062       } else {
03063        no_sep = 0;
03064       }
03065     } else {
03066       scheme_wrong_type(who, "path, string, 'up, 'same", i + idelta, argc, argv);
03067       return scheme_false;
03068     }
03069   }
03070 
03071   str[pos] = 0;
03072 
03073   if (kind == SCHEME_WINDOWS_PATH_KIND) {
03074     if (check_dos_slashslash_qm(str, pos, NULL, NULL, NULL) && !no_final_simplify) {
03075       /* Clean up additions to \\?\ path */
03076       int p;
03077       Scheme_Object *simp;
03078       p = pos;
03079       str = do_normal_path_seps(str, &p, first_len, 1, SCHEME_WINDOWS_PATH_KIND, NULL);
03080       str = remove_redundant_slashes(str, &p, first_len, NULL, SCHEME_WINDOWS_PATH_KIND);
03081       simp = do_simplify_path(scheme_make_sized_offset_kind_path(str, 0, p, 0, SCHEME_WINDOWS_PATH_KIND),
03082                               scheme_null, first_len, 0, 1, SCHEME_WINDOWS_PATH_KIND);
03083       if (SCHEME_FALSEP(simp))
03084         return scheme_make_sized_offset_kind_path(".\\", 0, 1, 0, SCHEME_WINDOWS_PATH_KIND);
03085       else
03086         return simp;
03087     }
03088   }
03089 
03090   return scheme_make_sized_offset_kind_path(str, 0, pos, alloc == PN_BUF_LEN, kind);
03091 }
03092 
03093 Scheme_Object *scheme_build_path(int argc, Scheme_Object **argv)
03094 {
03095   int kind = SCHEME_PLATFORM_PATH_KIND, i;
03096 
03097   for (i = 0; i < argc; i++) {
03098     if (SCHEME_GENERAL_PATHP(argv[i])) {
03099       kind = SCHEME_PATH_KIND(argv[i]);
03100       break;
03101     } else if (SCHEME_CHAR_STRINGP(argv[i])) {
03102       kind = SCHEME_PLATFORM_PATH_KIND;
03103       break;
03104     }
03105   }
03106   
03107   return do_build_path(argc, argv, 0, 0, kind);
03108 }
03109 
03110 static Scheme_Object *build_path_kind(int argc, Scheme_Object **argv)
03111 { 
03112   int kind;
03113 
03114   kind = extract_path_kind("build-path/convention-type", 0, argc, argv);
03115   return do_build_path(argc - 1, argv, 1, 0, kind);
03116 }
03117 
03118 static Scheme_Object *path_to_directory_path(int argc, Scheme_Object **argv)
03119 {
03120   Scheme_Object *inpath;
03121 
03122   inpath = argv[0];
03123 
03124   if (!SCHEME_GENERAL_PATH_STRINGP(inpath))
03125     scheme_wrong_type("path->directory-path", SCHEME_GENERAL_PATH_STRING_STR, 0, argc, argv);
03126 
03127   inpath = TO_PATH(inpath);
03128 
03129   return scheme_path_to_directory_path(inpath);
03130 }
03131 
03132 static Scheme_Object *do_split_path(const char *path, int len, Scheme_Object **base_out, int *id_out,
03133                                     int *cleaned_slashes, int kind)
03134 {
03135   char *s;
03136   int p, last_was_sep = 0, is_dir, no_up = 0, not_same;
03137   Scheme_Object *file;
03138   int allow_double_before = 0, drive_end, no_slash_sep = 0;
03139 
03140 #define MAKE_SPLIT(x, y, z) (*base_out = x, *id_out = z, y)
03141 
03142   s = (char *)path;
03143 
03144   if (kind == SCHEME_WINDOWS_PATH_KIND) {
03145     if ((len > 2) && IS_A_DOS_SEP(s[0]) && IS_A_DOS_SEP(s[1])) {
03146       if (check_dos_slashslash_qm(s, len, &drive_end, NULL, NULL)) {
03147         allow_double_before = drive_end;
03148         no_slash_sep = 1;
03149         if (drive_end < 0) {
03150           /* \\?\REL\ or \\?\RED\ path. Handle it directly as a special case. */
03151           int p, lit_start, dots_end;
03152           is_dir = 0;
03153           if (s[len - 1] == '\\') {
03154             --len;
03155             is_dir = 1;
03156           }
03157           dots_end = get_slashslash_qm_dot_ups_end(s, len, &lit_start);
03158           if (lit_start < len) {
03159             /* There's at least one literal path. */
03160             for (p = len; --p >= ((dots_end > 0) ? lit_start - 1 : lit_start); ) {
03161               if (s[p] == '\\') {
03162                 /* Prefix path element with \\?\REL\\: */
03163                 {
03164                   int len2, nsep;
03165                   char *s2;
03166                   Scheme_Object *dir;
03167                   len2 = len - p - 1 + 9;
03168                   s2 = scheme_malloc_atomic(len2 + 1);
03169                   memcpy(s2, "\\\\?\\REL\\\\", 9);
03170                   memcpy(s2 + 9, s + p + 1, len - p - 1);
03171                   s2[len2] = 0;
03172                   if ((dots_end == p) || (dots_end == p - 1)) {
03173                     /* stripping the only element: drop reundant separator(s) after .. */
03174                     nsep = ((dots_end == p) ? 0 : -1);
03175                   } else {
03176                     if (s[6] == 'L') {
03177                       /* preserve separator */
03178                       nsep = 1;
03179                     } else {
03180                       /* preserve one separator, but not two */
03181                       if (s[p - 1] == '\\')
03182                         nsep = 0;
03183                       else
03184                         nsep = 1;
03185                     }
03186                   }
03187                   dir = scheme_make_sized_offset_kind_path(s, 0, p + nsep, 1, SCHEME_WINDOWS_PATH_KIND);
03188                   file = scheme_make_sized_offset_kind_path(s2, 0, len2, 0, SCHEME_WINDOWS_PATH_KIND);
03189                   return MAKE_SPLIT(dir, file, is_dir);
03190                 }
03191               }
03192             }
03193           }
03194           /* Either no literal path elements, or only one element and no dots */
03195           if (dots_end > 0) {
03196             /* There are dots (so no literals) */
03197             if (dots_end - 3 > 8) {
03198               file = scheme_make_sized_offset_kind_path(s, 0, dots_end - 3, 1, SCHEME_WINDOWS_PATH_KIND);
03199               return MAKE_SPLIT(file, up_symbol, 1);
03200             } else
03201               return MAKE_SPLIT(relative_symbol, up_symbol, 1);
03202           } else {
03203             /* No dots, so there must be one element. */
03204             if (s[6] == 'L') {
03205               /* keep \\?\REL\ on path, and report 'relative as base */
03206               return MAKE_SPLIT(relative_symbol, 
03207                                 scheme_make_sized_offset_kind_path(s, 0, len, 1,
03208                                                                    SCHEME_WINDOWS_PATH_KIND), 
03209                                 is_dir);
03210             } else {
03211               /* Switch "D" to "L", and simplify base to just "\\" */
03212               char *naya;
03213               Scheme_Object *dir;
03214               naya = (char *)scheme_malloc_atomic(len + 2);
03215               memcpy(naya, s, len + 2);
03216               naya[6] = 'L';
03217               if (naya[8] != '\\') {
03218                 /* Make sure REL is followed by \\, just in case the element is
03219                    ".." (i.e., we had \\?\RED\..). */
03220                 memmove(naya + 9, naya + 8, len + 1 - 8);
03221                 naya[8] = '\\';
03222                 len++;
03223               }
03224               dir = scheme_make_sized_offset_kind_path("\\", 0, 1, 0,
03225                                                        SCHEME_WINDOWS_PATH_KIND);
03226               return MAKE_SPLIT(dir, 
03227                                 scheme_make_sized_offset_kind_path(naya, 0, len, 0,
03228                                                                    SCHEME_WINDOWS_PATH_KIND), 
03229                                 is_dir);
03230             }
03231           }
03232         } else {
03233           no_up = 1;
03234           if ((drive_end < len) && s[drive_end] == '\\') {
03235             /* Happens with \\?\c:\\, for example. */
03236             drive_end++;
03237           }
03238         }
03239       } else if (check_dos_slashslash_drive(s, 0, len, &drive_end, 0, 0)) {
03240         allow_double_before = 1;
03241         if ((drive_end < len) && IS_A_DOS_SEP(s[drive_end]))
03242           drive_end++;
03243       } else
03244         drive_end = 0;
03245     } else if ((len > 1) && is_drive_letter(s[0]) && (s[1] == ':')) {
03246       drive_end = 2;
03247       if ((drive_end < len) && IS_A_DOS_SEP(s[drive_end]))
03248         drive_end++;
03249     } else
03250       drive_end = 0;
03251   } else {
03252     drive_end = 0;
03253   }
03254 
03255   /* Look for confusing repeated separators (e.g. "x//y") */
03256   for (p = len; p--; ) {
03257     if (p > allow_double_before) {
03258       if (IS_A_SEP(kind, s[p]) && IS_A_SEP(kind, s[p - 1])) {
03259        /* Found it; copy without repeats */
03260        int q;
03261        char *old = s;
03262 
03263         if (cleaned_slashes)
03264           *cleaned_slashes = 1;
03265 
03266        s = (char *)scheme_malloc_atomic(len);
03267        --len;
03268 
03269        for (p = 0, q = 0; p < allow_double_before; p++) {
03270          s[q++] = old[p];
03271        }
03272 
03273        for (; p < len; p++) {
03274          if (!IS_A_SEP(kind, old[p]) || !IS_A_SEP(kind, old[p + 1]))
03275            s[q++] = old[p];
03276        }
03277        s[q++] = old[len];
03278        len = q;
03279        break;
03280       }
03281     }
03282   }
03283 
03284 # define IS_A_SPLIT_SEP(x) (((kind == SCHEME_WINDOWS_PATH_KIND) && no_slash_sep) ? (x == '\\') : IS_A_SEP(kind, x))
03285 
03286   if ((kind == SCHEME_WINDOWS_PATH_KIND) && (len <= drive_end))
03287     p = -1;
03288   else {
03289     for (p = len; p--; ) {
03290       if (IS_A_SPLIT_SEP(s[p])) {
03291         if (p != len - 1)
03292           break;
03293         else
03294           last_was_sep = 1;
03295       }
03296       if (kind == SCHEME_WINDOWS_PATH_KIND) {
03297        if (p < drive_end)
03298          break;
03299       }
03300     }
03301   }
03302   
03303   if (kind == SCHEME_UNIX_PATH_KIND) {
03304 #ifdef TILDE_IS_ABSOLUTE
03305     /* "./~..." can't be split at the beginning. */
03306     if ((p == 1)
03307         && s[0] == '.'
03308         && s[p + 1] == '~') {
03309       not_same = 1;
03310       p -= 2;
03311     } else
03312 #endif
03313       not_same = 0;
03314   } else
03315     not_same = 0;
03316 
03317   if (p < 0) {
03318     Scheme_Object *dir;
03319 
03320     /* No splitting available. 
03321        For Unx & DOS, it was relative or exactly root.
03322        For Mac, it is relative or root with trailing sep. */
03323     if (kind == SCHEME_UNIX_PATH_KIND) {
03324       if (s[0] == '/')
03325         return MAKE_SPLIT(scheme_false, scheme_make_sized_offset_kind_path(s, 0, len, 1, kind), 1);
03326 #ifdef TILDE_IS_ABSOLUTE
03327       if (s[0] == '~') {
03328         /* Strip ending slashes, if any. */
03329         while (IS_A_UNIX_SEP(s[len - 1])) {
03330           --len;
03331         }
03332         return MAKE_SPLIT(scheme_false, scheme_make_sized_offset_kind_path(s, 0, len, 1, kind), 1);
03333       }
03334 #endif
03335     } else {
03336       if (IS_A_DOS_SEP(s[0]) || drive_end)
03337         return MAKE_SPLIT(scheme_false, scheme_make_sized_offset_kind_path(s, 0, len, 1, kind), 1);
03338     }
03339 
03340     dir = relative_symbol;
03341 
03342     /* Check for 'up: */
03343     if (!no_up && (s[0] == '.') && (s[1] == '.')
03344        && (2 >= len || IS_A_SEP(kind, s[2]))) {
03345       file = up_symbol;
03346       is_dir = 1;
03347     } else if (!no_up && !not_same && (s[0] == '.') && (1 >= len || IS_A_SEP(kind, s[1]))) {
03348       file = same_symbol;
03349       is_dir = 1;
03350     } else {
03351       int delta;
03352       is_dir = last_was_sep;
03353       delta = 0;
03354       file = make_protected_sized_offset_path(no_up || is_dir, 
03355                                          s, 0, len - last_was_sep + delta, 1, 0,
03356                                               kind);
03357     }
03358     
03359     return MAKE_SPLIT(dir, file, is_dir);
03360   }
03361   
03362   /* Check for 'up and 'same: */
03363   if (!no_up && (s[p + 1] == '.') && (s[p + 2] == '.')
03364       && (p + 3 >= len || IS_A_SEP(kind, s[p + 3]))) {
03365     file = up_symbol;
03366     is_dir = 1;
03367   } else if (!no_up && (s[p + 1] == '.') && (p + 2 >= len || IS_A_SEP(kind, s[p + 2]))) {
03368     file = same_symbol;
03369     is_dir = 1;
03370   } else {
03371     int protected;
03372     if (kind == SCHEME_WINDOWS_PATH_KIND) {
03373       protected = no_up || last_was_sep;
03374     } else  {
03375       protected = 1;
03376     }
03377     file = make_protected_sized_offset_path(protected,
03378                                        s,
03379                                        p + 1, 
03380                                        len - p - last_was_sep - 1, 
03381                                        1, 0, kind);
03382     is_dir = last_was_sep;
03383   }
03384   
03385   /* Check directory */
03386   if (p > 0) {
03387     Scheme_Object *ss;
03388     ss = make_exposed_sized_offset_path(no_up, s, 0, p + 1, 1, kind);
03389     return MAKE_SPLIT(ss, 
03390                     file, 
03391                     is_dir);
03392   }
03393        
03394   /* p = 0; this means root dir. */
03395   {
03396     Scheme_Object *ss;
03397     ss = scheme_make_sized_offset_kind_path(s, 0, 1, 1, kind);
03398     return MAKE_SPLIT(ss, file, is_dir);
03399   }
03400 }
03401 
03402 Scheme_Object *scheme_split_path(const char *path, int len, Scheme_Object **base_out, int *id_out, int kind)
03403 {
03404   return do_split_path(path, len, base_out, id_out, NULL, kind);
03405 }
03406 
03407 #ifndef NO_FILE_SYSTEM_UTILS
03408 static Scheme_Object *split_path(int argc, Scheme_Object **argv)
03409 {
03410   char *s;
03411   int is_dir, len;
03412   Scheme_Object *three[3], *inpath;
03413 
03414   inpath = argv[0];
03415 
03416   if (!SCHEME_GENERAL_PATH_STRINGP(inpath))
03417     scheme_wrong_type("split-path", SCHEME_GENERAL_PATH_STRING_STR, 0, argc, argv);
03418 
03419   inpath = TO_PATH(inpath);
03420 
03421   s = SCHEME_PATH_VAL(inpath);
03422   len = SCHEME_PATH_LEN(inpath);
03423 
03424   if (!len) {
03425     scheme_raise_exn(MZEXN_FAIL_CONTRACT,
03426                    "split-path: path is an empty string");
03427   }
03428 
03429   if (has_null(s, len))
03430     raise_null_error("split-path", inpath, "");
03431 
03432   three[1] = scheme_split_path(s, len, &three[0], &is_dir, SCHEME_PATH_KIND(inpath));
03433 
03434   three[2] = is_dir ? scheme_true : scheme_false;
03435 
03436   return scheme_values(3, three);
03437 }
03438 #endif
03439 
03440 int scheme_is_relative_path(const char *s, long len, int kind)
03441 {
03442   if (!len)
03443     return 0;
03444 
03445   if (kind == SCHEME_UNIX_PATH_KIND) {
03446     return !((s[0] == '/') || WHEN_TILDE_IS_ABSOLUTE(s[0] == '~'));
03447   } else {
03448     int dlen;
03449     if (check_dos_slashslash_qm(s, len, &dlen, NULL, NULL)
03450        && (dlen < 0)) {
03451       if (dlen == -1)
03452         return 1; /* It's a \\?\REL\ path */
03453       else
03454         return 0; /* It's a \\?\RED\ path */
03455     }
03456 
03457     if (IS_A_DOS_SEP(s[0])
03458         || ((len >= 2) 
03459             && is_drive_letter(s[0])
03460             && (s[1] == ':')))
03461       return 0;
03462     else
03463       return 1;
03464   }
03465 }
03466 
03467 int scheme_is_complete_path(const char *s, long len, int kind)
03468 {
03469   if (!len)
03470     return 0;
03471 
03472   if (!kind)
03473     kind = SCHEME_PLATFORM_PATH_KIND;
03474 
03475   if (!scheme_is_relative_path(s, len, kind)) {
03476     if (kind == SCHEME_WINDOWS_PATH_KIND) {
03477       if (IS_A_DOS_SEP(s[0]) && IS_A_DOS_SEP(s[1])) {
03478         int dlen;
03479         if (check_dos_slashslash_qm(s, len, &dlen, NULL, NULL)) { /* not relative */
03480           return (dlen >= 0);
03481         } else if (check_dos_slashslash_drive(s, 0, len, NULL, 0, 0))
03482           return 1;
03483         else
03484           return 0;
03485       } else if ((len >= 2) 
03486                  && is_drive_letter(s[0])
03487                  && (s[1] == ':')) {
03488         return 1;
03489       } else
03490         return 0;
03491     } else
03492       return 1;
03493   } else 
03494     return 0;
03495 }
03496 
03497 static char *do_path_to_complete_path(char *filename, long ilen, const char *wrt, long wlen, int kind)
03498 {
03499   if (!scheme_is_complete_path(filename, ilen, kind)) {
03500     char *naya;
03501     int skip_sep = 0;
03502 
03503     if (!wrt) {
03504       Scheme_Object *wd;
03505       wd = CURRENT_WD();
03506       wrt = SCHEME_PATH_VAL(wd);
03507       wlen = SCHEME_PATH_LEN(wd);
03508       scheme_security_check_file("path->complete-path", NULL, SCHEME_GUARD_FILE_EXISTS);
03509     }
03510 
03511     if (kind == SCHEME_WINDOWS_PATH_KIND) {
03512       if (!scheme_is_relative_path(filename, ilen, kind)) {
03513         /* Absolute, not complete. Fill in the disk */
03514         wrt = get_drive_part(wrt, wlen);
03515         wlen = strlen(wrt);
03516         /* drop trailing separator */
03517         if (IS_A_DOS_SEP(wrt[wlen - 1]) 
03518             && !check_dos_slashslash_qm(wrt, wlen, NULL, NULL, NULL)) {
03519           wlen--;
03520         }
03521         skip_sep = 1;
03522       }
03523 
03524       if (check_dos_slashslash_qm(wrt, wlen, NULL, NULL, NULL) /* wrt is never relative */
03525           || check_dos_slashslash_qm(filename, ilen, NULL, NULL, NULL)) { /* filename might be \\?\REL\ */
03526         /* For \\?\, give up on fast path and use build-path */
03527         Scheme_Object *a[2], *p;
03528         p = scheme_make_sized_offset_kind_path((char *)wrt, 0, wlen, 1, SCHEME_WINDOWS_PATH_KIND);
03529         a[0] = p;
03530         p = scheme_make_sized_offset_kind_path(filename, 0, ilen, 1, SCHEME_WINDOWS_PATH_KIND);
03531         a[1] = p;
03532         p = do_build_path(2, a, 0, 0, SCHEME_WINDOWS_PATH_KIND);
03533         return SCHEME_PATH_VAL(p);
03534       }
03535     }
03536 
03537     naya = (char *)scheme_malloc_atomic(ilen + wlen + 2);
03538     memcpy(naya, wrt, wlen);
03539     if (!skip_sep)
03540       if (!IS_A_SEP(kind, naya[wlen - 1]))
03541        naya[wlen++] = FN_SEP(kind);
03542     if (kind == SCHEME_WINDOWS_PATH_KIND) {
03543       int w = wlen;
03544       strip_trailing_spaces(naya, &w, 0, 1);
03545       wlen = w;
03546     }
03547     memcpy(naya + wlen, filename, ilen);
03548     naya[wlen + ilen] = 0;
03549     
03550     return naya;
03551   }
03552 
03553   return filename;
03554 }
03555 
03556 static Scheme_Object *path_to_complete_path(int argc, Scheme_Object **argv)
03557 {
03558   Scheme_Object *p, *wrt;
03559   char *s;
03560   int len, kind;
03561 
03562   p = argv[0];
03563   if (!SCHEME_GENERAL_PATH_STRINGP(p))
03564     scheme_wrong_type("path->complete-path", SCHEME_GENERAL_PATH_STRING_STR, 0, argc, argv);
03565   p = TO_PATH(p);
03566   if (argc > 1) {
03567     wrt = argv[1];
03568     if (!SCHEME_GENERAL_PATH_STRINGP(wrt))
03569       scheme_wrong_type("path->complete-path", SCHEME_GENERAL_PATH_STRING_STR, 1, argc, argv);
03570     wrt = TO_PATH(wrt);
03571   } else
03572     wrt = NULL;
03573 
03574   kind = SCHEME_PATH_KIND(p);
03575   if (wrt) {
03576     if (SCHEME_PATH_KIND(wrt) != kind) {
03577       scheme_arg_mismatch("path->complete-path",
03578                           "convention of first path incompatible with convention of second path: ",
03579                           argv[1]);
03580     }
03581   } else if (kind != SCHEME_PLATFORM_PATH_KIND) {
03582     scheme_arg_mismatch("path->complete-path",
03583                         "no second path supplied, and given path is not for the current platform: ",
03584                         argv[0]);
03585   }
03586 
03587   s = SCHEME_PATH_VAL(p);
03588   len = SCHEME_PATH_LEN(p);
03589 
03590   if (has_null(s, len))
03591     raise_null_error("path->complete-path", p, "");
03592 
03593   if (wrt) {
03594     char *ws;
03595     int wlen;
03596 
03597     ws = SCHEME_PATH_VAL(wrt);
03598     wlen = SCHEME_PATH_LEN(wrt);
03599     
03600     if (has_null(ws, wlen))
03601       raise_null_error("path->complete-path", p, "");
03602 
03603     if (!scheme_is_complete_path(ws, wlen, kind))
03604       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
03605                      "path->complete-path: second argument is not a complete path: \"%q\"",
03606                      ws);
03607 
03608     if (!scheme_is_complete_path(s, len, kind)) {
03609       s = do_path_to_complete_path(s, len, ws, wlen, kind);
03610       return scheme_make_sized_offset_kind_path(s, 0, strlen(s), 0, kind);
03611     }
03612   } else if (!scheme_is_complete_path(s, len, kind)) {
03613     s = do_path_to_complete_path(s, len, NULL, 0, kind);
03614 
03615     return scheme_make_sized_offset_kind_path(s, 0, strlen(s), 0, kind);
03616   }
03617    
03618   return p;
03619 }
03620 
03621 Scheme_Object *scheme_path_to_complete_path(Scheme_Object *path, Scheme_Object *relto_path)
03622 {
03623   Scheme_Object *a[2];
03624   a[0] = path;
03625   a[1] = relto_path;
03626   return path_to_complete_path(relto_path ? 2 : 1, a);
03627 }
03628 
03629 #ifndef NO_FILE_SYSTEM_UTILS
03630 
03631 static char *filename_for_error(Scheme_Object *p)
03632 {
03633   return do_expand_filename(p, NULL, 0,
03634                          NULL,
03635                          NULL,
03636                          1, 1,
03637                          0, SCHEME_PLATFORM_PATH_KIND,
03638                             0);
03639 }
03640 
03641 static Scheme_Object *delete_file(int argc, Scheme_Object **argv)
03642 {
03643   int errid;
03644 
03645   if (!SCHEME_PATH_STRINGP(argv[0]))
03646     scheme_wrong_type("delete-file", SCHEME_PATH_STRING_STR, 0, argc, argv);
03647 
03648   while (1) {
03649     if (!MSC_W_IZE(unlink)(MSC_WIDE_PATH(scheme_expand_string_filename(argv[0],
03650                                                                "delete-file",
03651                                                                NULL,
03652                                                                SCHEME_GUARD_FILE_DELETE))))
03653       return scheme_void;
03654     else if (errno != EINTR)
03655       break;
03656   }
03657   errid = errno;
03658   
03659   scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, 
03660                  "delete-file: cannot delete file: \"%q\" (%e)",
03661                  filename_for_error(argv[0]),
03662                  errid);
03663 
03664   return NULL;
03665 }
03666 
03667 static Scheme_Object *rename_file(int argc, Scheme_Object **argv)
03668 {
03669   int exists_ok = 0;
03670   char *src, *dest;
03671   Scheme_Object *bss, *bsd;
03672 
03673   if (!SCHEME_PATH_STRINGP(argv[0]))
03674     scheme_wrong_type("rename-file-or-directory", SCHEME_PATH_STRING_STR, 0, argc, argv);
03675   if (!SCHEME_PATH_STRINGP(argv[1]))
03676     scheme_wrong_type("rename-file-or-directory", SCHEME_PATH_STRING_STR, 1, argc, argv);
03677   if (argc > 2)
03678     exists_ok = SCHEME_TRUEP(argv[2]);
03679 
03680   bss = argv[0];
03681   bsd = argv[1];
03682 
03683   src = scheme_expand_string_filename(bss,
03684                                   "rename-file-or-directory",
03685                                   NULL,
03686                                   SCHEME_GUARD_FILE_READ);
03687   dest = scheme_expand_string_filename(bsd,
03688                                    "rename-file-or-directory",
03689                                    NULL,
03690                                    SCHEME_GUARD_FILE_WRITE);
03691 
03692 # ifdef DOS_FILE_SYSTEM
03693   if (MoveFileExW(WIDE_PATH_COPY(src), WIDE_PATH(dest), (exists_ok ? MOVEFILE_REPLACE_EXISTING : 0)))
03694     return scheme_void;
03695 
03696   {
03697     int errid;
03698     errid = GetLastError();
03699     errno = errid;
03700   }
03701 
03702   if (errno == ERROR_CALL_NOT_IMPLEMENTED) {
03703     /* Then we have the great misfortune of running in Windows 9x. If
03704        exists_ok, then do something no less stupid than the OS
03705        itself: */
03706     int errid;
03707     if (exists_ok)
03708       MSC_W_IZE(unlink)(MSC_WIDE_PATH(dest));
03709     if (MoveFileW(WIDE_PATH_COPY(src), WIDE_PATH(dest)))
03710       return scheme_void;
03711     errid = GetLastError();
03712     errno = errid;
03713   }
03714 
03715 # define MOVE_ERRNO_FORMAT "%E"
03716 # else
03717   if (!exists_ok && (scheme_file_exists(dest) || scheme_directory_exists(dest))) {
03718     exists_ok = -1;
03719     errno = EEXIST;
03720     goto failed;
03721   }
03722   
03723   while (1) {
03724     if (!rename(src, dest))
03725       return scheme_void;
03726     else if (errno != EINTR)
03727       break;
03728   }
03729 # define MOVE_ERRNO_FORMAT "%e"
03730 # endif
03731 
03732 #ifndef DOS_FILE_SYSTEM
03733 failed:
03734 #endif
03735   scheme_raise_exn((exists_ok < 0) ? MZEXN_FAIL_FILESYSTEM_EXISTS : MZEXN_FAIL_FILESYSTEM, 
03736                  "rename-file-or-directory: cannot rename file or directory: %q to: %q (" MOVE_ERRNO_FORMAT ")",
03737                  filename_for_error(argv[0]),
03738                  filename_for_error(argv[1]),
03739                  errno);
03740   
03741   return NULL;
03742 }
03743 
03744 static Scheme_Object *copy_file(int argc, Scheme_Object **argv)
03745 {
03746   char *src, *dest, *reason = NULL;
03747   int pre_exists = 0;
03748   Scheme_Object *bss, *bsd;
03749 
03750   if (!SCHEME_PATH_STRINGP(argv[0]))
03751     scheme_wrong_type("copy-file", SCHEME_PATH_STRING_STR, 0, argc, argv);
03752   if (!SCHEME_PATH_STRINGP(argv[1]))
03753     scheme_wrong_type("copy-file", SCHEME_PATH_STRING_STR, 1, argc, argv);
03754 
03755   bss = argv[0];
03756   bsd = argv[1];
03757 
03758   src = scheme_expand_string_filename(bss,
03759                                   "copy-file",
03760                                   NULL,
03761                                   SCHEME_GUARD_FILE_READ);
03762   dest = scheme_expand_string_filename(bsd,
03763                                    "copy-file",
03764                                    NULL, 
03765                                    SCHEME_GUARD_FILE_WRITE | SCHEME_GUARD_FILE_DELETE);
03766 
03767 #ifdef UNIX_FILE_SYSTEM
03768   {
03769 # define COPY_BUFFER_SIZE 2048
03770     FILE *s, *d;
03771     char b[COPY_BUFFER_SIZE];
03772     long len;
03773     int ok;
03774     struct stat buf;
03775 
03776 
03777     do {
03778       ok = stat(src, &buf);
03779     } while ((ok == -1) && (errno == EINTR));
03780 
03781     if (ok || S_ISDIR(buf.st_mode)) {
03782       reason = "source file does not exist";
03783       goto failed;
03784     }
03785 
03786     do {
03787       ok = stat(dest, &buf);
03788     } while ((ok == -1) && (errno == EINTR));
03789 
03790     if (!ok) {
03791       reason = "destination already exists";
03792       pre_exists = 1;
03793       goto failed;
03794     }
03795 
03796     s = fopen(src, "rb");
03797     if (!s) {
03798       reason = "cannot open source file";
03799       goto failed;
03800     }
03801 
03802     d = fopen(dest, "wb");
03803     if (!d) {
03804       fclose(s);
03805       reason = "cannot open destination file";
03806       goto failed;
03807     }
03808     
03809     ok = 1;
03810     while ((len = fread(b, 1, COPY_BUFFER_SIZE, s))) {
03811       if (fwrite(b, 1, len, d) != len) {
03812        ok = 0;
03813        break;
03814       }
03815     }
03816     if (!feof(s))
03817       ok = 0;
03818 
03819     fclose(s);
03820     fclose(d);
03821 
03822     if (ok) {
03823       while (1) {
03824        if (!chmod(dest, buf.st_mode))
03825          return scheme_void;
03826        else if (errno != EINTR)
03827          break;
03828       }
03829       reason = "cannot set destination's mode";
03830     } else
03831       reason = "read or write failed";
03832   }
03833  failed:
03834 #endif
03835 #ifdef DOS_FILE_SYSTEM
03836   if (CopyFileW(WIDE_PATH_COPY(src), WIDE_PATH(dest), TRUE))
03837     return scheme_void;
03838   
03839   reason = "copy failed";
03840   if (GetLastError() == ERROR_ALREADY_EXISTS)
03841     pre_exists = 1;
03842 #endif
03843 
03844   scheme_raise_exn(pre_exists ? MZEXN_FAIL_FILESYSTEM_EXISTS : MZEXN_FAIL_FILESYSTEM, 
03845                  "copy-file: %s; cannot copy: %q to: %q",
03846                  reason,
03847                  filename_for_error(argv[0]),
03848                  filename_for_error(argv[1]));
03849   return NULL;
03850 }
03851 
03852 static Scheme_Object *relative_path_p(int argc, Scheme_Object **argv)
03853 {
03854   char *s;
03855   int len;
03856   Scheme_Object *bs;
03857 
03858   if (!SCHEME_GENERAL_PATH_STRINGP(argv[0]))
03859     scheme_wrong_type("relative-path?", SCHEME_GENERAL_PATH_STRING_STR, 0, argc, argv);
03860 
03861   bs = TO_PATH(argv[0]);
03862 
03863   s = SCHEME_PATH_VAL(bs);
03864   len = SCHEME_PATH_LEN(bs);
03865 
03866   if (has_null(s, len))
03867     return scheme_false;
03868 
03869   return (scheme_is_relative_path(s, len, SCHEME_PATH_KIND(bs))
03870          ? scheme_true
03871          : scheme_false);
03872 }
03873 
03874 static Scheme_Object *complete_path_p(int argc, Scheme_Object **argv)
03875 {
03876   char *s;
03877   int len;
03878   Scheme_Object *bs;
03879 
03880   if (!SCHEME_GENERAL_PATH_STRINGP(argv[0]))
03881     scheme_wrong_type("complete-path?", SCHEME_GENERAL_PATH_STRING_STR, 0, argc, argv);
03882 
03883   bs = TO_PATH(argv[0]);
03884 
03885   s = SCHEME_PATH_VAL(bs);
03886   len = SCHEME_PATH_LEN(bs);
03887 
03888   if (has_null(s, len))
03889     return scheme_false;
03890 
03891   return (scheme_is_complete_path(s, len, SCHEME_PATH_KIND(bs))
03892          ? scheme_true
03893          : scheme_false);
03894 }
03895 
03896 static Scheme_Object *absolute_path_p(int argc, Scheme_Object **argv)
03897 {
03898   char *s;
03899   int len;
03900   Scheme_Object *bs;
03901 
03902   if (!SCHEME_GENERAL_PATH_STRINGP(argv[0]))
03903     scheme_wrong_type("absolute-path?", SCHEME_GENERAL_PATH_STRING_STR, 0, argc, argv);
03904 
03905   bs = TO_PATH(argv[0]);
03906 
03907   s = SCHEME_PATH_VAL(bs);
03908   len = SCHEME_PATH_LEN(bs);
03909 
03910   if (has_null(s, len))
03911     return scheme_false;
03912 
03913   return (!scheme_is_relative_path(s, len, SCHEME_PATH_KIND(bs))
03914          ? scheme_true
03915          : scheme_false);
03916 }
03917 
03918 static Scheme_Object *resolve_path(int argc, Scheme_Object *argv[])
03919 {
03920 #ifndef NO_READLINK
03921 #define SL_NAME_MAX 2048
03922   char buffer[SL_NAME_MAX];
03923 #endif
03924 #ifndef NO_READLINK
03925   long len;
03926   int copied = 0;
03927 #endif
03928   char *filename;
03929   int expanded;
03930 
03931   if (!SCHEME_GENERAL_PATH_STRINGP(argv[0]))
03932     scheme_wrong_type("resolve-path", SCHEME_GENERAL_PATH_STRING_STR, 0, argc, argv);
03933 
03934   filename = do_expand_filename(argv[0],
03935                             NULL,
03936                             0,
03937                             "resolve-path",
03938                             &expanded,
03939                             1, 0,
03940                             SCHEME_GUARD_FILE_EXISTS,
03941                                 SCHEME_PLATFORM_PATH_KIND,
03942                                 0);
03943 
03944 #ifndef NO_READLINK
03945   {
03946     char *fullfilename = filename;
03947 
03948     len = strlen(fullfilename);
03949     if (!scheme_is_complete_path(fullfilename, len, SCHEME_PLATFORM_PATH_KIND)) {
03950       fullfilename = do_path_to_complete_path(fullfilename, len, NULL, 0, SCHEME_PLATFORM_PATH_KIND);
03951       copied = 1;
03952     }
03953 
03954     /* Make sure path doesn't have trailing separator: */
03955     len = strlen(fullfilename);
03956     while (len && IS_A_SEP(SCHEME_PLATFORM_PATH_KIND, fullfilename[len - 1])) {
03957       if (!expanded && !copied) {
03958        fullfilename = scheme_strdup(fullfilename);
03959        copied = 1;
03960       }
03961       fullfilename[--len] = 0;
03962     }
03963 
03964     while (1) {
03965       len = readlink(fullfilename, buffer, SL_NAME_MAX);
03966       if (len == -1) {
03967        if (errno != EINTR)
03968          break;
03969       } else
03970        break;
03971     }
03972 
03973     if (len > 0)
03974       return scheme_make_sized_path(buffer, len, 1);
03975   }
03976 #endif
03977 
03978   if (!expanded)
03979     return argv[0];
03980   else
03981     return scheme_make_sized_path(filename, strlen(filename), 1);
03982 }
03983 
03984 static Scheme_Object *convert_literal_relative(Scheme_Object *file)
03985 {
03986   int ln;
03987   char *f;
03988   f = SCHEME_PATH_VAL(file);
03989   ln = SCHEME_PATH_LEN(file);
03990   if ((ln == 11) && !strcmp(f, "\\\\?\\REL\\\\.."))
03991     return up_symbol;
03992   else if ((ln == 10) && !strcmp(f, "\\\\?\\REL\\\\."))
03993     return same_symbol;
03994   return file;
03995 }
03996 
03997 static Scheme_Object *simplify_qm_path(Scheme_Object *path)
03998 {
03999   /* path is already expanded, so the only remaining
04000      clean-ups are dropping a trailing separator,
04001      and getting rid of \\?\ if it's not actually needed. */
04002   char *s = SCHEME_PATH_VAL(path);
04003   int drive_end, clean_start, len = SCHEME_PATH_LEN(path), fixed = 0, i;
04004   int drop_extra_slash = -1, set_slash = -1, element_start;
04005   int found_bad = 0, start_special_check = 0, is_dir = 0, norm_unc = 0, drop_ss_slash = 0;
04006 
04007   if ((s[len - 1] == '\\')
04008       && (s[len - 2] != '\\')
04009       && do_path_to_directory_path(s, 0, len - 1, scheme_true, 1, SCHEME_WINDOWS_PATH_KIND)) {
04010     --len;
04011     fixed = 1;
04012   }
04013 
04014   check_dos_slashslash_qm(s, len, &drive_end, &clean_start, NULL);
04015   if ((drive_end == 7)
04016       && is_drive_letter(s[4])
04017       && (s[5] == ':')) {
04018     /* Maybe don't need \\?\ for \\?\C:\... */
04019     start_special_check = 7;
04020     drive_end = 4;
04021   } else if ((drive_end == 8)
04022             && (s[4] == '\\')
04023             && is_drive_letter(s[5])
04024             && (s[6] == ':')) {
04025     /* Maybe don't need \\?\\ for \\?\\C:\... */
04026     start_special_check = 8;
04027     drive_end = 5;
04028     drop_ss_slash = 1;
04029   } else if (drive_end == -2) {
04030     /* \\?\RED\ */
04031     int lit_start;
04032     get_slashslash_qm_dot_ups_end(s, len, &lit_start);
04033     start_special_check = lit_start;
04034     drive_end = lit_start - 1;
04035   } else if (drive_end < 0) {
04036     int lit_start, dots_end;
04037     dots_end = get_slashslash_qm_dot_ups_end(s, len, &lit_start);
04038     if (lit_start == len) {
04039       /* just keep the dots */
04040       return scheme_path_to_directory_path(scheme_make_sized_offset_kind_path(s, 8, dots_end - 8, 1, SCHEME_WINDOWS_PATH_KIND));
04041     }
04042     start_special_check = lit_start;
04043     if (dots_end < 9)
04044       drive_end = lit_start; /* no dots, so just keep the literal part */
04045     else {
04046       drive_end = 8; /* \\?\REL\..\, and we keep the .. */
04047       drop_extra_slash = dots_end;
04048       is_dir = 1;
04049     }
04050   } else if ((clean_start == 7) 
04051             && ((s[4] == 'U') || (s[4] == 'u'))
04052             && ((s[5] == 'N') || (s[5] == 'n'))
04053             && ((s[6] == 'C') || (s[6] == 'c'))) {
04054     if (drive_end == len) {
04055       is_dir = 1;
04056     }
04057     drive_end = 6;
04058     start_special_check = 7; /* \\?\UNC */
04059     set_slash = 6;
04060     norm_unc = 1;
04061   } else if ((clean_start == 8) 
04062             && (s[4] == '\\')
04063             && ((s[5] == 'U') || (s[5] == 'u'))
04064             && ((s[6] == 'N') || (s[6] == 'n'))
04065             && ((s[7] == 'C') || (s[7] == 'c'))) {
04066     if (drive_end == len) {
04067       is_dir = 1;
04068     }
04069     drive_end = 7;
04070     start_special_check = 8; /* \\?\\UNC */
04071     set_slash = 7;
04072     norm_unc = 1;
04073     drop_ss_slash = 1;
04074   } else {
04075     /* We have a weird root. Give up. */
04076     found_bad = 1;
04077     start_special_check = len;
04078   }
04079 
04080   if (!found_bad) {
04081     element_start = start_special_check;
04082     for (i = element_start; 1; i++) {
04083       if ((i == len) || (s[i] == '\\')) {
04084        if (element_start <= i - 1) {
04085          /* Need the protection? */
04086          Scheme_Object *v;
04087          int any_more = 0, j;
04088        
04089          for (j = i+1; j < len; j++) {
04090            if (s[j] != '\\') {
04091              any_more = 1;
04092              break;
04093            }
04094          }
04095        
04096          v = make_protected_sized_offset_path(1, 
04097                                           s, element_start, i - element_start,
04098                                           1, 
04099                                           (any_more ? 2 : 1),
04100                                                SCHEME_WINDOWS_PATH_KIND);
04101          if (SCHEME_TRUEP(v)) {
04102            found_bad = 1;
04103            break;
04104          }
04105        }
04106        if (i == len)
04107          break;
04108        element_start = i + 1;
04109       }
04110     }
04111   }
04112 
04113   if (found_bad) {
04114     if (norm_unc) {
04115       if ((s[4 + drop_ss_slash] == 'U')
04116          && (s[5 + drop_ss_slash] == 'N')
04117          && (s[6 + drop_ss_slash] == 'C'))
04118        norm_unc = 0;
04119     }
04120     if (norm_unc || drop_ss_slash) {
04121       if (!fixed) {
04122        char *naya;
04123        naya = (char *)scheme_malloc_atomic(len);
04124        memcpy(naya, s, len);
04125        s = naya;
04126        fixed = 1;
04127       }
04128       if (drop_ss_slash) {
04129        memmove(s + 3, s + 4, len - 4);
04130        len--;
04131       }
04132       if (norm_unc) {
04133        s[4] = 'U';
04134        s[5] = 'N';
04135        s[6] = 'C';
04136       }
04137     }
04138     if (fixed)
04139       path = scheme_make_sized_offset_kind_path(s, 0, len, 1, SCHEME_WINDOWS_PATH_KIND);
04140     return path;
04141   } else {
04142     if (drop_extra_slash > -1) {
04143       char *naya;
04144       naya = (char *)scheme_malloc_atomic(len);
04145       memcpy(naya, s, drop_extra_slash);
04146       memcpy(naya + drop_extra_slash, s + drop_extra_slash + 1, len - drop_extra_slash - 1);
04147       s = naya;
04148       --len;
04149     }
04150     if (set_slash > -1) {
04151       char *naya;
04152       naya = (char *)scheme_malloc_atomic(len);
04153       memcpy(naya, s, len);
04154       naya[set_slash] = '\\';
04155       s = naya;
04156     }
04157     path = scheme_make_sized_offset_kind_path(s, drive_end, len - drive_end, 1, SCHEME_WINDOWS_PATH_KIND);
04158     if (is_dir)
04159       path = scheme_path_to_directory_path(path);
04160     return path;
04161   }
04162 }
04163 
04164 static Scheme_Object *do_simplify_path(Scheme_Object *path, Scheme_Object *cycle_check, int skip, 
04165                                    int use_filesystem, 
04166                                        int force_rel_up,
04167                                        int kind)
04168      /* When !use_filesystem, the result can be #f for an empty relative
04169        path, and it can contain leading ".."s, or ".."s after an initial
04170         "~" path with "~" paths are absolute.
04171        When force_rel_up under Windows, "\\?\REL\.." from split-path is
04172        treated like 'up. */
04173 {
04174   int isdir, cleaned_slashes = 0, must_be_dir = 0, last_was_dir = 0, did_first = 0;
04175   Scheme_Object *file = scheme_false, *base;
04176 
04177   /* cleanse-path doesn't touch the filesystem. Always start with
04178      that, to get things basically tidy. */
04179   if (kind == SCHEME_WINDOWS_PATH_KIND) {
04180     char *s;
04181     int expanded, add_sep = 0;
04182     s = do_expand_filename(path, SCHEME_PATH_VAL(path), SCHEME_PATH_LEN(path),
04183                            NULL, &expanded, 0, 0, 0, kind, 0);
04184     {
04185       int slen;
04186       if (expanded)
04187         slen = strlen(s);
04188       else
04189         slen = SCHEME_PATH_LEN(path);
04190       s = do_normal_path_seps(s, &slen, 0, 0, SCHEME_WINDOWS_PATH_KIND, &expanded);
04191     }
04192     if (expanded) {
04193       path = scheme_make_sized_offset_kind_path(s, 0, -1, 0, SCHEME_WINDOWS_PATH_KIND);
04194     }
04195     if (!check_dos_slashslash_qm(SCHEME_PATH_VAL(path), SCHEME_PATH_LEN(path), NULL, NULL, &add_sep)) {
04196       int len = SCHEME_PATH_LEN(path);
04197       s = strip_trailing_spaces(SCHEME_PATH_VAL(path), &len, 0, 0);
04198       if (s != SCHEME_PATH_VAL(path))
04199         path = scheme_make_sized_offset_kind_path(s, 0, -1, 0, SCHEME_WINDOWS_PATH_KIND);
04200     } else if (add_sep) {
04201       int len = SCHEME_PATH_LEN(path);
04202       if ((add_sep < len) && (s[add_sep] != '\\')) {
04203         /* Add two \, as in \\?\c -> \\?\\\c */
04204         char *naya;
04205         naya = (char *)scheme_malloc_atomic(len + 3);
04206         memcpy(naya, s, add_sep);
04207         naya[add_sep] = '\\';
04208         naya[add_sep+1] = '\\';
04209         memcpy(naya + add_sep + 2, s + add_sep, len + 1 - add_sep);
04210         len += 2;
04211         path = scheme_make_sized_offset_kind_path(naya, 0, len, 0, SCHEME_WINDOWS_PATH_KIND);
04212       } else if (((add_sep + 1) < len) && (s[add_sep] == '\\') && (s[add_sep+1] != '\\')) {
04213         /* Add \, as in \\?\\c -> \\?\\\c */
04214         char *naya;
04215         naya = (char *)scheme_malloc_atomic(len + 2);
04216         memcpy(naya, s, add_sep);
04217         naya[add_sep] = '\\';
04218         memcpy(naya + add_sep + 1, s + add_sep, len + 1 - add_sep);
04219         len++;
04220         path = scheme_make_sized_offset_kind_path(naya, 0, len, 0, SCHEME_WINDOWS_PATH_KIND);
04221       }
04222     }
04223   }
04224 
04225   /* Fast check; avoids split operations, if possible.
04226      Also responsible for determing whether there's a
04227      redundant or missing trailing slash in the case that
04228      the path is just a root. */
04229   {
04230     char *s;
04231     int len, i, saw_dot = 0;
04232     s = SCHEME_PATH_VAL(path);
04233     len = SCHEME_PATH_LEN(path);
04234 
04235     if (kind == SCHEME_WINDOWS_PATH_KIND) {
04236       if (!skip && check_dos_slashslash_qm(s, len, NULL, NULL, NULL)) {
04237         if (!force_rel_up) {
04238          int drive_end;
04239           path = simplify_qm_path(path);
04240          len = SCHEME_PATH_LEN(path);
04241          if (check_dos_slashslash_qm(SCHEME_PATH_VAL(path), len, &drive_end, NULL, NULL)) {
04242            /* If it's a drive... */
04243            if (drive_end == len) {
04244              /* Make it a directory path. */
04245              path = scheme_path_to_directory_path(path);
04246            }
04247          }
04248          return path;
04249         } else {
04250          /* force_rel_up means that we want a directory: */
04251           return scheme_path_to_directory_path(path);
04252        }
04253       }
04254       if (!skip && check_dos_slashslash_drive(s, 0, len, NULL, 1, 0)) {
04255         /* A UNC drive (with no further elements). 
04256           Remove extra trailing slashes, if any... */
04257         for (i = len; IS_A_DOS_SEP(s[i-1]); i--) { }
04258         if (i < len - 1) {
04259           path = scheme_make_sized_offset_kind_path(s, 0, i, 1, SCHEME_WINDOWS_PATH_KIND);
04260         }
04261        /* ... but make it a directory path. */
04262         path = scheme_path_to_directory_path(path);
04263       }
04264 
04265       if (skip) {
04266         while (s[skip] == '\\') {
04267           skip++;
04268         }
04269       }
04270     }
04271 
04272     i = skip;
04273     if (kind == SCHEME_WINDOWS_PATH_KIND) {
04274       if (!i && (len >= 2) && is_drive_letter(s[0]) && s[1] == ':') {
04275         i = 2;
04276       } else if (!i) {
04277         int drive_end;
04278         if (check_dos_slashslash_drive(s, 0, len, &drive_end, 0, 0)) {
04279           i = drive_end;
04280         }
04281       }
04282     }
04283 
04284     for (; i < len; i++) {
04285       if (s[i] == '.')
04286        saw_dot++;
04287       else if (IS_A_SEP(kind, s[i])) {
04288        if ((saw_dot == 1) || (saw_dot == 2))
04289          break;
04290         if ((i + 1 < len) && (IS_A_SEP(kind, s[i]))) {
04291           /* Double slash to clean up... */
04292           break;
04293         }
04294        saw_dot = 0;
04295       } else
04296        saw_dot = 3;
04297     }
04298 
04299     if (i == len) {
04300       if ((saw_dot != 1) && (saw_dot != 2)) {
04301         /* Still may need to add trailing separator if it's syntactically a directory. */
04302         if (path_is_simple_dir_without_sep(path))
04303           path = scheme_path_to_directory_path(path);
04304         return path;
04305       }
04306     }
04307     /* There's a ., .., or // in the path... */
04308   }
04309 
04310   /* Check whether it can be simplified: */
04311   if (!cleaned_slashes) {
04312     base = path;
04313     do {
04314       char *s;
04315       int len;
04316       s = SCHEME_PATH_VAL(base);
04317       len = SCHEME_PATH_LEN(base);
04318       if (len <= skip)
04319         break;
04320       file = do_split_path(s, len, &base, &isdir, &cleaned_slashes, kind);
04321       if (kind == SCHEME_WINDOWS_PATH_KIND) {
04322         if (force_rel_up) {
04323           file = convert_literal_relative(file);
04324         }
04325       }
04326       if (SCHEME_SYMBOLP(file) || cleaned_slashes)
04327         break;
04328     } while (SCHEME_GENERAL_PATHP(base));
04329   } else
04330     file = scheme_false;
04331 
04332   if (SCHEME_SYMBOLP(file) || cleaned_slashes) {
04333     /* It can be simplified: */
04334     char *s;
04335     int len;
04336     Scheme_Object *accum = scheme_null, *result;
04337 
04338     s = SCHEME_PATH_VAL(path);
04339     len = SCHEME_PATH_LEN(path);
04340 
04341     if (use_filesystem
04342        && !scheme_is_complete_path(s, len, kind)) {
04343       /* Make it absolute */
04344       s = scheme_expand_string_filename(path,
04345                                    "simplify-path", NULL,
04346                                    SCHEME_GUARD_FILE_EXISTS);
04347       len = strlen(s);
04348     }
04349 
04350     /* Check for cycles: */
04351     if (use_filesystem) {
04352       {
04353        Scheme_Object *l = cycle_check;
04354        while (!SCHEME_NULLP(l)) {
04355          Scheme_Object *p = SCHEME_CAR(l);
04356          if ((len == SCHEME_PATH_LEN(p))
04357              && !strcmp(s, SCHEME_PATH_VAL(p))) {
04358            /* Cycle of links detected */
04359            scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
04360                           "simplify-path: cycle detected at link: \"%q\"",
04361                           s);
04362          }
04363          l = SCHEME_CDR(l);
04364        }
04365       }
04366     
04367       cycle_check = scheme_make_pair(scheme_make_sized_path(s, len, 0), 
04368                                  cycle_check);
04369     }
04370 
04371     /* Split the path into a list. */
04372     while (1) {
04373       if (len <= skip) {
04374        accum = scheme_make_pair(scheme_make_sized_offset_kind_path(s, 0, len, 0, kind), accum);
04375        break;
04376       }
04377 
04378       file = scheme_split_path(s, len, &base, &isdir, kind);
04379       if (kind == SCHEME_WINDOWS_PATH_KIND) {
04380         if (force_rel_up) {
04381           file = convert_literal_relative(file);
04382           if (SCHEME_SYMBOLP(file))
04383             isdir = 1;
04384         }
04385       }
04386 
04387       if (!did_first) {
04388         must_be_dir = isdir;
04389         did_first = 1;
04390       }
04391 
04392       if (SAME_OBJ(file, same_symbol)) {
04393        /* Drop it */
04394       } else
04395        accum = scheme_make_pair(file, accum);
04396       
04397       if (SCHEME_GENERAL_PATHP(base)) {
04398        s = SCHEME_PATH_VAL(base);
04399        len = SCHEME_PATH_LEN(base);
04400       } else {
04401        if (use_filesystem) {
04402          accum = scheme_make_pair(file, SCHEME_CDR(accum));
04403        }
04404        break;
04405       }
04406     }
04407 
04408     /* Now assemble the result */
04409     if (SCHEME_NULLP(accum)) {
04410       /* Only happens when !use_filesystem */
04411       result = scheme_false;
04412     } else {
04413       result = SCHEME_CAR(accum);
04414       if (SAME_OBJ(result, up_symbol)) {
04415        /* Only happens when !use_filesystem */
04416        result = scheme_false;
04417       } else
04418        accum = SCHEME_CDR(accum);
04419     }
04420 
04421     /* Build up path, watching for links just before a ..: */
04422     while (!SCHEME_NULLP(accum)) {
04423       if (SAME_OBJ(SCHEME_CAR(accum), up_symbol)) {
04424        if (use_filesystem) {
04425          /* Look for symlink in result-so-far. */
04426          Scheme_Object *new_result, *a[1];
04427 
04428          while (1) {
04429            a[0] = result;
04430            new_result = resolve_path(1, a);
04431        
04432            /* Was it a link? */
04433            if (result != new_result) {
04434              /* It was a link. Is the new result relative? */
04435              if (!scheme_is_complete_path(SCHEME_PATH_VAL(new_result),
04436                                       SCHEME_PATH_LEN(new_result),
04437                                            kind)) {
04438               Scheme_Object *aa[2], *result_base;
04439               /* Yes - resolve it relative to result's base: */
04440               scheme_split_path(SCHEME_PATH_VAL(result),
04441                               SCHEME_PATH_LEN(result),
04442                               &result_base,
04443                               &isdir,
04444                                   kind);
04445               aa[0] = result_base;
04446               aa[1] = new_result;
04447               new_result = do_build_path(2, aa, 0, 0, SCHEME_PLATFORM_PATH_KIND);
04448              }
04449            
04450              /* Simplify the new result */
04451              result = do_simplify_path(new_result, cycle_check, skip, 
04452                                    use_filesystem, force_rel_up, kind);
04453              cycle_check = scheme_make_pair(new_result, cycle_check);
04454            } else
04455              break;
04456          }
04457        }
04458        
04459        /* Do one 'up: */
04460        {
04461          accum = SCHEME_CDR(accum);
04462          if (SCHEME_FALSEP(result)) {
04463            /* Empty relative path so far */
04464            if (skip) /* => input was a \\?\ path, and it must be relative */
04465              result = scheme_make_sized_offset_kind_path("\\\\?\\REL\\..", 0, 10, 0, SCHEME_WINDOWS_PATH_KIND);
04466            else
04467              result = scheme_make_sized_offset_kind_path("..", 0, 2, 0, kind);
04468          } else {
04469            Scheme_Object *next, *to_go;
04470            to_go = scheme_split_path(SCHEME_PATH_VAL(result),
04471                                   SCHEME_PATH_LEN(result),
04472                                   &next,
04473                                   &isdir,
04474                                       kind);
04475            if (SAME_OBJ(to_go, up_symbol)) {
04476              /* We're building a sequence of ups... */
04477              Scheme_Object *a[2];
04478              a[0] = result;
04479              a[1] = up_symbol;
04480              result = do_build_path(2, a, 0, 1, kind);
04481 #ifdef TILDE_IS_ABSOLUTE
04482            } else if ((kind == SCHEME_UNIX_PATH_KIND)
04483                        && SCHEME_FALSEP(next)
04484                        && SCHEME_GENERAL_PATHP(to_go)
04485                        && SCHEME_PATH_VAL(to_go)[0] == '~') {
04486              /* Can't delete a leading ~ for .. */
04487              Scheme_Object *a[2];
04488              a[0] = result;
04489              a[1] = up_symbol;
04490              result = do_build_path(2, a, 0, 1, kind);
04491 #endif
04492            } else if (!SCHEME_GENERAL_PATH_STRINGP(next)) {
04493              if (SCHEME_FALSEP(next)) {
04494               /* Result is already a root, so we just drop the .. */
04495              } else {
04496               /* Result is empty relative path */
04497               result = scheme_false;
04498              }
04499            } else
04500              result = next;
04501          }
04502        }
04503 
04504         last_was_dir = 1;
04505       } else {
04506        /* Add path element onto the result: */
04507        if (SCHEME_FALSEP(result))
04508          result = SCHEME_CAR(accum);
04509        else {
04510          Scheme_Object *a[2];
04511          a[0] = result;
04512          a[1] = SCHEME_CAR(accum);
04513          result = do_build_path(2, a, 0, 0, kind);
04514        }
04515        accum = SCHEME_CDR(accum);
04516         last_was_dir = 0;
04517       }
04518     }
04519 
04520     if ((must_be_dir || last_was_dir) && !SCHEME_FALSEP(result)) {
04521       result = scheme_path_to_directory_path(result);
04522     }
04523 
04524     return result;
04525   } else
04526     return path;
04527 }
04528 
04529 static Scheme_Object *simplify_path(int argc, Scheme_Object *argv[])
04530 {
04531   char *s;
04532   int len, use_fs, kind;
04533   Scheme_Object *bs, *r;
04534 
04535   if (!SCHEME_GENERAL_PATH_STRINGP(argv[0]))
04536     scheme_wrong_type("simplify-path", SCHEME_GENERAL_PATH_STRING_STR, 0, argc, argv);
04537 
04538   bs = TO_PATH(argv[0]);
04539 
04540   s = SCHEME_PATH_VAL(bs);
04541   len = SCHEME_PATH_LEN(bs);
04542 
04543   if (has_null(s, len))
04544     raise_null_error("simplify-path", argv[0], "");
04545 
04546   use_fs = ((argc <= 1) || SCHEME_TRUEP(argv[1]));
04547   kind = SCHEME_PATH_KIND(bs);
04548 
04549   if (use_fs && (kind != SCHEME_PLATFORM_PATH_KIND)) {
04550     scheme_arg_mismatch("simplify-path",
04551                         "in use-filesystem mode, path is not for the current platform: ",
04552                         argv[0]);
04553   }
04554   
04555   r = do_simplify_path(bs, scheme_null, 0, use_fs, 0, kind);
04556 
04557   if (SCHEME_FALSEP(r)) {
04558     /* Input was just 'same: */
04559     return scheme_make_sized_offset_kind_path((kind == SCHEME_WINDOWS_PATH_KIND) ? ".\\" : "./", 0, 2, 0, kind);
04560   }
04561 
04562   return r;
04563 }
04564 
04565 static Scheme_Object *current_drive(int argc, Scheme_Object *argv[])
04566 {
04567 #ifdef DOS_FILE_SYSTEM
04568   char *drive;
04569 
04570   drive = scheme_getdrive();
04571 
04572   return scheme_make_sized_path(drive, strlen(drive), 0);
04573 #else
04574   scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED, "current-drive: not supported");
04575   return NULL;
04576 #endif
04577 }
04578 
04579 static Scheme_Object *cleanse_path(int argc, Scheme_Object *argv[])
04580 {
04581   char *filename;
04582   int expanded;
04583 
04584   if (!SCHEME_PATH_STRINGP(argv[0]))
04585     scheme_wrong_type("cleanse-path", SCHEME_PATH_STRING_STR, 0, argc, argv);
04586 
04587   filename = do_expand_filename(argv[0],
04588                             NULL,
04589                             0,
04590                             "cleanse-path",
04591                             &expanded,
04592                             1, 0,
04593                             SCHEME_GUARD_FILE_EXISTS, 
04594                                 SCHEME_PLATFORM_PATH_KIND,
04595                                 0);
04596   
04597   if (!expanded && SCHEME_PATHP(argv[0]))
04598     return argv[0];
04599   else
04600     return scheme_make_sized_path(filename, strlen(filename), 1);
04601 }
04602 
04603 static Scheme_Object *expand_user_path(int argc, Scheme_Object *argv[])
04604 {
04605   char *filename;
04606   int expanded;
04607 
04608   if (!SCHEME_PATH_STRINGP(argv[0]))
04609     scheme_wrong_type("expand-user-path", SCHEME_PATH_STRING_STR, 0, argc, argv);
04610 
04611   filename = do_expand_filename(argv[0],
04612                             NULL,
04613                             0,
04614                             "expand-user-path",
04615                             &expanded,
04616                             1, 0,
04617                             SCHEME_GUARD_FILE_EXISTS, 
04618                                 SCHEME_PLATFORM_PATH_KIND,
04619                                 1);
04620 
04621   if (!expanded && SCHEME_PATHP(argv[0]))
04622     return argv[0];
04623   else
04624     return scheme_make_sized_path(filename, strlen(filename), 1);
04625 }
04626 
04627 #ifdef USE_FINDFIRST
04628 void do_find_close(void *p) 
04629 {
04630   FIND_CLOSE(*(FF_HANDLE_TYPE *)p);
04631 }
04632 #endif
04633 
04634 static Scheme_Object *do_directory_list(int break_ok, int argc, Scheme_Object *argv[])
04635 {
04636 #if !defined(NO_READDIR) || defined(USE_FINDFIRST)
04637   char *filename;
04638   Scheme_Object * volatile first = scheme_null, * volatile last = NULL, *n, *elem;
04639 #endif
04640 #ifndef NO_READDIR
04641   DIR *dir;
04642   int nlen;
04643   struct dirent *e;
04644 #endif
04645 #ifdef USE_FINDFIRST
04646   char *pattern;
04647   int len;
04648   FF_HANDLE_TYPE hfile, *hfile_ptr = NULL;
04649   FF_TYPE info;
04650 #endif
04651   volatile int counter = 0;
04652 
04653   if (argc && !SCHEME_PATH_STRINGP(argv[0]))
04654     scheme_wrong_type("directory-list", SCHEME_PATH_STRING_STR, 0, argc, argv);
04655 
04656 #if defined(NO_READDIR) && !defined(USE_FINDFIRST)
04657   return scheme_null;
04658 #else
04659 
04660   if (argc) {
04661     Scheme_Object *path = argv[0];
04662 # ifdef USE_FINDFIRST
04663     while (1) {
04664 # endif
04665       filename = do_expand_filename(path, NULL, 0, 
04666                                 break_ok ? "directory-list" : NULL, 
04667                                 NULL, 1, 259 - 4 /* leave room for \*.* in Windows */, 
04668                                 break_ok ? SCHEME_GUARD_FILE_READ : 0, 
04669                                     SCHEME_PLATFORM_PATH_KIND,
04670                                     0);
04671       if (!filename)
04672        return NULL;
04673 # ifdef USE_FINDFIRST
04674       /* Eliminate "." and "..": */
04675       if (SAME_OBJ(path, argv[0])) {
04676        Scheme_Object *old;
04677        old = scheme_make_path(filename);
04678        path = do_simplify_path(old, scheme_null, 0, 1, 0, SCHEME_WINDOWS_PATH_KIND);
04679        if (SAME_OBJ(path, old))
04680          break;
04681       } else
04682        break;
04683     }
04684 # endif
04685   } else {
04686     filename = SCHEME_PATH_VAL(CURRENT_WD());
04687     if (break_ok) {
04688       scheme_security_check_file("directory-list", NULL, SCHEME_GUARD_FILE_EXISTS);
04689       scheme_security_check_file("directory-list", filename, SCHEME_GUARD_FILE_READ);
04690     }
04691   }
04692 
04693 # ifdef USE_FINDFIRST
04694 
04695   if (!filename)
04696     pattern = "*.*";
04697   else {
04698     char *nf;
04699     int is_unc = 0, d, nd;
04700     len = strlen(filename);
04701     if ((len > 1) && IS_A_DOS_SEP(filename[0]) && check_dos_slashslash_drive(filename, 0, len, NULL, 0, 0))
04702       is_unc = 1;
04703     nf = scheme_normal_path_seps(filename, &len, 0);
04704     pattern = (char *)scheme_malloc_atomic(len + 14);
04705     
04706     if ((scheme_stupid_windows_machine > 0)
04707        || check_dos_slashslash_qm(filename, len, NULL, NULL, NULL)) {
04708       d = 0;
04709       nd = 0;
04710     } else {
04711       pattern[0] = '\\';
04712       pattern[1] = '\\';
04713       pattern[2] = '?';
04714       pattern[3] = '\\';
04715       if (is_unc) {
04716        pattern[4] = 'U';
04717        pattern[5] = 'N';
04718        pattern[6] = 'C';
04719        pattern[7] = '\\';
04720        d = 8;
04721        nd = 2;
04722       } else {
04723        d = 4;
04724        nd = 0;
04725       }
04726     }
04727     memcpy(pattern + d, nf + nd, len - nd);
04728     len += (d - nd);
04729     if (len && !IS_A_DOS_SEP(pattern[len - 1]))
04730       pattern[len++] = '\\';      
04731     memcpy(pattern + len, "*.*", 4);
04732   }
04733 
04734   hfile = FIND_FIRST(WIDE_PATH(pattern), &info);
04735   if (FIND_FAILED(hfile)) {
04736     if (!filename)
04737       return scheme_null;
04738     if (break_ok)
04739       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
04740                        "directory-list: could not open \"%q\" (%E)",
04741                        filename,
04742                        GetLastError());  
04743     return NULL;
04744   }
04745 
04746   do {
04747     if ((GET_FF_NAME(info)[0] == '.')
04748        && (!GET_FF_NAME(info)[1] || ((GET_FF_NAME(info)[1] == '.')
04749                                   && !GET_FF_NAME(info)[2]))) {
04750       /* skip . and .. */
04751     } else {
04752       n = make_protected_path(NARROW_PATH(info.cFileName));
04753       elem = scheme_make_pair(n, scheme_null);
04754       if (last)
04755        SCHEME_CDR(last) = elem;
04756       else
04757        first = elem;
04758       last = elem;
04759     }
04760     counter++;
04761     if (break_ok && !(counter & 0x15)) {
04762       if (!hfile_ptr) {
04763        hfile_ptr = (FF_HANDLE_TYPE *)scheme_malloc_atomic(sizeof(FF_HANDLE_TYPE));
04764        *hfile_ptr = hfile;
04765       }
04766       BEGIN_ESCAPEABLE(do_find_close, hfile_ptr);
04767       scheme_thread_block(0);
04768       END_ESCAPEABLE();
04769       scheme_current_thread->ran_some = 1;
04770     }
04771   } while (FIND_NEXT(hfile, &info));
04772   
04773   FIND_CLOSE(hfile);
04774 
04775   return first;
04776 # else
04777   
04778   dir = opendir(filename ? filename : ".");
04779   if (!dir) {
04780     if (!filename)
04781       return scheme_null;
04782     if (break_ok)
04783       scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
04784                        "directory-list: could not open \"%q\" (%e)",
04785                        filename,
04786                        errno);
04787     return NULL;
04788   }
04789   
04790   while ((e = readdir(dir))) {
04791 #  ifdef DIRENT_NO_NAMLEN
04792     nlen = strlen(e->d_name);
04793 #  else
04794     nlen = e->d_namlen;
04795 #  endif
04796 #  if defined(UNIX_FILE_SYSTEM) || defined(DOS_FILE_SYSTEM)
04797     if (nlen == 1 && e->d_name[0] == '.')
04798       continue;
04799     if (nlen == 2 && e->d_name[0] == '.' && e->d_name[1] == '.')
04800       continue;
04801 #  endif
04802     n = make_protected_sized_offset_path(1, e->d_name, 0, nlen, 1, 0, SCHEME_PLATFORM_PATH_KIND);
04803     elem = scheme_make_pair(n, scheme_null);
04804     if (last)
04805       SCHEME_CDR(last) = elem;
04806     else
04807       first = elem;
04808     last = elem;
04809 
04810     counter++;
04811     if (break_ok && !(counter & 0xF)) {
04812       BEGIN_ESCAPEABLE(closedir, dir);
04813       scheme_thread_block(0);
04814       END_ESCAPEABLE();
04815       scheme_current_thread->ran_some = 1;
04816     }
04817   }
04818   
04819   closedir(dir);
04820 
04821   return first;
04822 # endif
04823 #endif
04824 }
04825 
04826 static Scheme_Object *directory_list(int argc, Scheme_Object *argv[])
04827 {
04828   return do_directory_list(1, argc, argv);
04829 }
04830 
04831 char *scheme_find_completion(char *fn)
04832 {
04833   int len;
04834   Scheme_Object *p, *l, *a[2], *f, *matches, *fst;
04835   int isdir, max_match;
04836   Scheme_Object *base;
04837   
04838   len = strlen(fn);
04839 
04840   if (!len)
04841     return NULL;
04842   
04843   f = scheme_split_path(fn, len, &base, &isdir, SCHEME_PLATFORM_PATH_KIND);
04844   if (isdir) {
04845     /* Look for single file/prefix in directory: */
04846     base = scheme_make_sized_path(fn, len, 0);
04847     f = scheme_make_sized_path("", 0, 0);
04848   } else {
04849     if (!SCHEME_PATHP(base))
04850       return NULL;
04851   }
04852 
04853   a[0] = base;
04854   l = do_directory_list(0, 1, a);
04855   if (!l)
04856     return NULL;
04857 
04858   matches = scheme_null;
04859   while (SCHEME_PAIRP(l)) {
04860     p = SCHEME_CAR(l);
04861     if ((SCHEME_PATH_LEN(p) >= SCHEME_PATH_LEN(f))
04862        && !memcmp(SCHEME_PATH_VAL(f), SCHEME_PATH_VAL(p), SCHEME_PATH_LEN(f))) {
04863       matches = scheme_make_pair(p, matches);
04864     }
04865     l = SCHEME_CDR(l);
04866   }
04867 
04868   if (SCHEME_NULLP(matches))
04869     return NULL;
04870 
04871   if (SCHEME_NULLP(SCHEME_CDR(matches))) {
04872     /* One match */
04873     a[0] = base;
04874     a[1] = SCHEME_CAR(matches);
04875     p = scheme_build_path(2, a);
04876     a[0] = p;
04877     if (SCHEME_TRUEP(directory_exists(1, a))) {
04878       /* Add trailing separator if one is not there */
04879       fn = SCHEME_PATH_VAL(p);
04880       len = SCHEME_PATH_LEN(p);
04881       if (!IS_A_SEP(SCHEME_PLATFORM_PATH_KIND, fn[len-1])) {
04882        char *naya;
04883        naya = (char *)scheme_malloc_atomic(len + 2);
04884        memcpy(naya, fn, len);
04885        naya[len++] = FN_SEP(SCHEME_PLATFORM_PATH_KIND);
04886        naya[len] = 0;
04887        fn = naya;
04888       }
04889     } else
04890       fn = SCHEME_PATH_VAL(p);
04891     return fn;
04892   }
04893 
04894   fst = SCHEME_CAR(matches);
04895   max_match = SCHEME_PATH_LEN(fst);
04896   for (l = SCHEME_CDR(matches); SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
04897     int i, l2;
04898     p = SCHEME_CAR(l);
04899     l2 = SCHEME_PATH_LEN(p);
04900     if (max_match < l2)
04901       l2 = max_match;
04902     else if (l2 < max_match)
04903       max_match = l2;
04904     for (i = 0; i < l2; i++) {
04905       if (SCHEME_PATH_VAL(fst)[i] != SCHEME_PATH_VAL(p)[i]) {
04906        max_match = i;
04907        break;
04908       }
04909     }
04910   }
04911 
04912   if (max_match <= SCHEME_PATH_LEN(f)) 
04913     /* No longer match available: */
04914     return NULL;
04915 
04916   /* Build match */
04917   a[0] = base;
04918   a[1] = scheme_make_sized_path(SCHEME_PATH_VAL(fst), max_match, 0);
04919   f = scheme_build_path(2, a);  
04920 
04921   return SCHEME_PATH_VAL(f);
04922 }
04923 
04924 static Scheme_Object *explode_path(Scheme_Object *p)
04925 {
04926   Scheme_Object *l = scheme_null, *base, *name;
04927   int isdir;
04928 
04929   while (1) {
04930     name = scheme_split_path(SCHEME_PATH_VAL(p), SCHEME_PATH_LEN(p), &base, &isdir, SCHEME_PATH_KIND(p));
04931     l = scheme_make_pair(name, l);
04932 
04933     if (!SCHEME_PATHP(base)) {
04934       l = scheme_make_pair(base, l);
04935       return l;
04936     }
04937     p = base;
04938   }
04939 }
04940 
04941 Scheme_Object *scheme_extract_relative_to(Scheme_Object *obj, Scheme_Object *dir)
04942 {
04943   Scheme_Object *de, *oe;
04944 
04945   de = explode_path(dir);
04946   oe = explode_path(obj);
04947 
04948   while (SCHEME_PAIRP(de)
04949         && SCHEME_PAIRP(oe)) {
04950     if (!scheme_equal(SCHEME_CAR(de), SCHEME_CAR(oe)))
04951       return obj;
04952     de = SCHEME_CDR(de);
04953     oe = SCHEME_CDR(oe);
04954   }
04955 
04956   if (SCHEME_NULLP(de)) {
04957     Scheme_Object *a[2];
04958    
04959     if (SCHEME_NULLP(oe)) {
04960       a[0] = same_symbol;
04961       obj = scheme_build_path(1, a);
04962     } else {
04963       obj = SCHEME_CAR(oe);
04964       oe = SCHEME_CDR(oe);
04965     }
04966 
04967     while (SCHEME_PAIRP(oe)) {
04968       a[0] = obj;
04969       a[1] = SCHEME_CAR(oe);
04970       obj = scheme_build_path(2, a);
04971       oe = SCHEME_CDR(oe);
04972     }
04973   }
04974 
04975   return obj;
04976 }
04977 
04978 static Scheme_Object *filesystem_root_list(int argc, Scheme_Object *argv[])
04979 {
04980   Scheme_Object *first = scheme_null;
04981 #if defined(DOS_FILE_SYSTEM)
04982   Scheme_Object *last = NULL, *v;
04983 #endif
04984 
04985   scheme_security_check_file("filesystem-root-list", NULL, SCHEME_GUARD_FILE_EXISTS);
04986 
04987 #ifdef UNIX_FILE_SYSTEM 
04988   first = scheme_make_pair(scheme_make_path("/"), scheme_null);
04989 #endif
04990 #ifdef DOS_FILE_SYSTEM
04991   {
04992 #   define DRIVE_BUF_SIZE 1024
04993     char drives[DRIVE_BUF_SIZE], *s;
04994     long len, ds;
04995     UINT oldmode;
04996 
04997     len = GetLogicalDriveStrings(DRIVE_BUF_SIZE, drives);
04998     if (len <= DRIVE_BUF_SIZE)
04999       s = drives;
05000     else {
05001       s = scheme_malloc_atomic(len + 1);
05002       GetLogicalDriveStrings(len + 1, s);
05003     }
05004 
05005     ds = 0;
05006     oldmode = SetErrorMode(SEM_FAILCRITICALERRORS);      
05007     while (s[ds]) {
05008       DWORD a, b, c, d;
05009       /* GetDiskFreeSpace effectively checks whether we can read the disk: */
05010       if (GetDiskFreeSpace(s XFORM_OK_PLUS ds, &a, &b, &c, &d)) {
05011        v = scheme_make_pair(scheme_make_sized_offset_path(s, ds, -1, 1), scheme_null);
05012        if (last)
05013          SCHEME_CDR(last) = v;
05014        else
05015          first = v;
05016        last = v;
05017       }
05018       ds += strlen(s XFORM_OK_PLUS ds) + 1;
05019     }
05020     SetErrorMode(oldmode);
05021   }
05022 #endif
05023 
05024   return first;
05025 }
05026 
05027 static Scheme_Object *make_directory(int argc, Scheme_Object *argv[])
05028 {
05029 #ifdef NO_MKDIR
05030   return scheme_false;
05031 #else
05032   char *filename;
05033   int exists_already = 0;
05034   int len, copied;
05035 
05036   if (!SCHEME_PATH_STRINGP(argv[0]))
05037     scheme_wrong_type("make-directory", SCHEME_PATH_STRING_STR, 0, argc, argv);
05038 
05039   filename = scheme_expand_string_filename(argv[0],
05040                                       "make-directory",
05041                                       &copied,
05042                                       SCHEME_GUARD_FILE_WRITE);
05043   
05044   /* Make sure path doesn't have trailing separator: */
05045   len = strlen(filename);
05046   while (len && IS_A_SEP(SCHEME_PLATFORM_PATH_KIND, filename[len - 1])) {
05047     if (!copied) {
05048       filename = scheme_strdup(filename);
05049       copied = 1;
05050     }
05051     filename[--len] = 0;
05052   }
05053 
05054   while (1) {
05055     if (!MSC_W_IZE(mkdir)(MSC_WIDE_PATH(filename)
05056 #  ifndef MKDIR_NO_MODE_FLAG
05057                        , 0777
05058 # endif
05059                        ))
05060       return scheme_void;
05061     else if (errno != EINTR)
05062       break;
05063   }
05064 
05065   exists_already = (errno == EEXIST);
05066 # define MKDIR_EXN_TYPE "%e"
05067 
05068   scheme_raise_exn(exists_already ? MZEXN_FAIL_FILESYSTEM_EXISTS : MZEXN_FAIL_FILESYSTEM,
05069                  "make-directory: cannot make directory: %q (" MKDIR_EXN_TYPE ")",
05070                  filename_for_error(argv[0]),
05071                  errno);
05072   return NULL;
05073 #endif
05074 }
05075 
05076 static Scheme_Object *delete_directory(int argc, Scheme_Object *argv[])
05077 {
05078 #ifdef NO_RMDIR
05079   return scheme_false;
05080 #else
05081 # ifdef DOS_FILE_SYSTEM
05082   int tried_cwd = 0;
05083 # endif
05084   char *filename;
05085 
05086   if (!SCHEME_PATH_STRINGP(argv[0]))
05087     scheme_wrong_type("delete-directory", SCHEME_PATH_STRING_STR, 0, argc, argv);
05088 
05089   filename = scheme_expand_string_filename(argv[0],
05090                                       "delete-directory",
05091                                       NULL,
05092                                       SCHEME_GUARD_FILE_DELETE);
05093 
05094   while (1) {
05095     if (!MSC_W_IZE(rmdir)(MSC_WIDE_PATH(filename)))
05096       return scheme_void;
05097 # ifdef DOS_FILE_SYSTEM
05098     else if ((errno == EACCES) && !tried_cwd) {
05099       /* Maybe we're using the target directory. Try a real setcwd. */
05100       Scheme_Object *tcd;
05101       tcd = scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_DIRECTORY);
05102       scheme_os_setcwd(SCHEME_PATH_VAL(tcd), 0);
05103       tried_cwd = 1;
05104     }
05105 # endif
05106     else if (errno != EINTR)
05107       break;
05108   }
05109 
05110   scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
05111                  "delete-directory: cannot delete directory: %q (%e)",
05112                  filename_for_error(argv[0]),
05113                  errno);
05114   return NULL;
05115 #endif
05116 }
05117 
05118 static Scheme_Object *make_link(int argc, Scheme_Object *argv[])
05119 {
05120   char *src;
05121   Scheme_Object *dest;
05122   int copied;
05123 
05124   if (!SCHEME_PATH_STRINGP(argv[0]))
05125     scheme_wrong_type("make-file-or-directory-link", SCHEME_PATH_STRING_STR, 0, argc, argv);
05126   if (!SCHEME_PATH_STRINGP(argv[1]))
05127     scheme_wrong_type("make-file-or-directory-link", SCHEME_PATH_STRING_STR, 0, argc, argv);
05128 
05129   dest = argv[0];
05130   /* dest does not get expanded, but we need to make sure it's a path */
05131   dest = TO_PATH(dest);
05132   if (has_null(SCHEME_PATH_VAL(dest), SCHEME_PATH_LEN(dest))) {
05133     raise_null_error("make-file-or-directory-link", dest, "");
05134     return NULL;
05135   }
05136 
05137   src = scheme_expand_string_filename(argv[1],
05138                                   "make-file-or-directory-link",
05139                                   &copied,
05140                                   SCHEME_GUARD_FILE_WRITE);
05141 
05142   scheme_security_check_file_link("make-file-or-directory-link", 
05143                               src, 
05144                               SCHEME_PATH_VAL(dest));
05145 
05146 #if defined(DOS_FILE_SYSTEM)
05147   scheme_raise_exn(MZEXN_FAIL_UNSUPPORTED,
05148                  "make-file-or-directory-link: link creation not supported on this platform; "
05149                  "cannot create link: %Q",
05150                  argv[1]);
05151 #else
05152   while (1) {
05153     if (!symlink(SCHEME_PATH_VAL(dest), src))
05154       return scheme_void;
05155     else if (errno != EINTR)
05156       break;
05157   }
05158 
05159   scheme_raise_exn((errno == EEXIST) ? MZEXN_FAIL_FILESYSTEM_EXISTS : MZEXN_FAIL_FILESYSTEM,
05160                  "make-file-or-directory-link: cannot make link: %q (%e)",
05161                  filename_for_error(argv[1]),
05162                  errno);
05163 #endif
05164 
05165   return NULL;
05166 }
05167 
05168 static Scheme_Object *file_modify_seconds(int argc, Scheme_Object **argv)
05169 {
05170   char *file;
05171   int set_time = 0;
05172   UNBUNDLE_TIME_TYPE mtime;
05173   struct MSC_IZE(stat) buf;
05174 
05175   if (!SCHEME_PATH_STRINGP(argv[0]))
05176     scheme_wrong_type("file-or-directory-modify-seconds", SCHEME_PATH_STRING_STR, 0, argc, argv);
05177 
05178   set_time = ((argc > 1) && SCHEME_TRUEP(argv[1]));
05179 
05180   file = scheme_expand_string_filename(argv[0],
05181                                    "file-or-directory-modify-seconds",
05182                                    NULL,
05183                                    (set_time
05184                                    ? SCHEME_GUARD_FILE_WRITE
05185                                    : SCHEME_GUARD_FILE_READ));
05186   
05187   if (set_time) {
05188     if (!SCHEME_INTP(argv[1]) && !SCHEME_BIGNUMP(argv[1])) {
05189       scheme_wrong_type("file-or-directory-modify-seconds", "exact integer or #f", 1, argc, argv);
05190       return NULL;
05191     }
05192     if (!scheme_get_time_val(argv[1], &mtime)) {
05193       scheme_raise_exn(MZEXN_FAIL_CONTRACT,
05194                      "file-or-directory-modify-seconds: integer %s is out-of-range",
05195                      scheme_make_provided_string(argv[1], 0, NULL));
05196       return NULL;
05197     }
05198   } else
05199     mtime = 0;
05200 
05201   if (argc > 2) {
05202     scheme_check_proc_arity("file-or-directory-modify-seconds", 0, 2, argc, argv);
05203   }
05204 
05205 # ifdef DOS_FILE_SYSTEM
05206   if (!set_time) {
05207     int len = strlen(file);
05208     Scheme_Object *secs;
05209 
05210     if (UNC_stat(file, len, NULL, NULL, &secs, NULL))
05211       return secs;
05212   } else 
05213 # endif
05214     {
05215       while (1) {
05216        if (set_time) {
05217          struct MSC_IZE(utimbuf) ut;
05218          ut.actime = mtime;
05219          ut.modtime = mtime;
05220          if (!MSC_W_IZE(utime)(MSC_WIDE_PATH(file), &ut))
05221            return scheme_void;
05222        } else {
05223          if (!MSC_W_IZE(stat)(MSC_WIDE_PATH(file), &buf))
05224            return scheme_make_integer_value_from_time(buf.st_mtime);
05225        }
05226        if (errno != EINTR)
05227          break;
05228       }
05229     }
05230 
05231   if (argc > 2) {
05232     return _scheme_tail_apply(argv[2], 0, NULL);
05233   }
05234 
05235   scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
05236                  "file-or-directory-modify-seconds: error %s file/directory time: %q (%e)",
05237                  set_time ? "setting" : "getting",
05238                  filename_for_error(argv[0]),
05239                  errno);
05240   return NULL;
05241 }
05242 
05243 #if defined(UNIX_FILE_SYSTEM) && !defined(NO_UNIX_USERS)
05244 # define GROUP_CACHE_SIZE 10
05245 typedef struct {
05246   gid_t gid;
05247   char set, in;
05248 } Group_Mem_Cache;
05249 static Group_Mem_Cache group_mem_cache[GROUP_CACHE_SIZE];
05250 static int user_in_group(uid_t uid, gid_t gid)
05251 {
05252   struct group *g;
05253   struct passwd *pw;
05254   int i, in;
05255 
05256   for (i = 0; i < GROUP_CACHE_SIZE; i++) {
05257     if (group_mem_cache[i].set && (group_mem_cache[i].gid == gid))
05258       return group_mem_cache[i].in;
05259   }
05260 
05261   pw = getpwuid(uid);
05262   if (!pw)
05263     return 0;
05264 
05265   g = getgrgid(gid);
05266   if (!g)
05267     return 0;
05268 
05269   for (i = 0; g->gr_mem[i]; i++) {
05270     if (!strcmp(g->gr_mem[i], pw->pw_name))
05271       break;
05272   }
05273 
05274   in = !!(g->gr_mem[i]);
05275 
05276   for (i = 0; i < GROUP_CACHE_SIZE; i++) {
05277     if (!group_mem_cache[i].set) {
05278       group_mem_cache[i].set = 1;
05279       group_mem_cache[i].gid = gid;
05280       group_mem_cache[i].in = in;
05281     }
05282   }
05283 
05284   return in;
05285 }
05286 
05287 static int have_user_ids = 0;
05288 static uid_t uid, euid;
05289 static gid_t gid, egid;
05290 #endif
05291 
05292 static Scheme_Object *file_or_dir_permissions(int argc, Scheme_Object *argv[])
05293 {
05294   Scheme_Object *l = scheme_null;
05295   char *filename;
05296 
05297   if (!SCHEME_PATH_STRINGP(argv[0]))
05298     scheme_wrong_type("file-or-directory-permissions", SCHEME_PATH_STRING_STR, 0, argc, argv);
05299 
05300   filename = scheme_expand_string_filename(argv[0],
05301                                       "file-or-directory-permissions",
05302                                       NULL,
05303                                       SCHEME_GUARD_FILE_READ);
05304 
05305 # ifdef NO_STAT_PROC
05306   return scheme_null;
05307 # else
05308 #  ifdef UNIX_FILE_SYSTEM
05309   /* General strategy for permissions (to deal with setuid)
05310      taken from euidaccess() in coreutils... */
05311 #   ifndef NO_UNIX_USERS
05312   if (have_user_ids == 0) {
05313     have_user_ids = 1;
05314     uid = getuid();
05315     gid = getgid();
05316     euid = geteuid();
05317     egid = getegid();
05318   }
05319 
05320   if ((uid == euid) && (gid == egid)) {
05321     /* Not setuid; use access() */
05322     int read, write, execute, ok;
05323     
05324     do {
05325       ok = access(filename, R_OK);
05326     } while ((ok == -1) && (errno == EINTR));
05327     read = !ok;
05328 
05329     if (ok && (errno != EACCES))
05330       l = NULL;
05331     else {
05332       do {
05333        ok = access(filename, W_OK);
05334       } while ((ok == -1) && (errno == EINTR));
05335       write = !ok;
05336       
05337       if (ok && (errno != EACCES))
05338        l = NULL;
05339       else {
05340        do {
05341          ok = access(filename, X_OK);
05342        } while ((ok == -1) && (errno == EINTR));
05343        execute = !ok;
05344       
05345         /* Don't fail at the exec step if the user is the
05346            superuser and errno is EPERM; under Mac OS X,
05347            at least, such a failure simply means tha the
05348            file is not executable. */
05349        if (ok && (errno != EACCES) 
05350             && (uid || gid || (errno != EPERM))) {
05351          l = NULL;
05352        } else {
05353          if (read)
05354            l = scheme_make_pair(read_symbol, l);
05355          if (write)
05356            l = scheme_make_pair(write_symbol, l);
05357          if (execute)
05358            l = scheme_make_pair(execute_symbol, l);
05359        }
05360       }
05361     }
05362   } else 
05363 #  endif
05364     {
05365       /* Use stat, because setuid, or because or no user info available */
05366       struct stat buf;
05367       int read, write, execute;
05368 
05369       if (stat(filename, &buf))
05370        l = NULL;
05371       else {
05372 #   ifndef NO_UNIX_USERS
05373        if (euid == 0) {
05374          /* Super-user can read/write anything, and can
05375             execute anything that someone can execute */
05376          read = 1;
05377          write = 1;
05378          execute = !!(buf.st_mode & (S_IXUSR | S_IXGRP | S_IXOTH));
05379        } else if (buf.st_uid == euid) {
05380          read = !!(buf.st_mode & S_IRUSR);
05381          write = !!(buf.st_mode & S_IWUSR);
05382          execute = !!(buf.st_mode & S_IXUSR);
05383        } else if ((egid == buf.st_gid) || user_in_group(euid, buf.st_gid)) {
05384          read = !!(buf.st_mode & S_IRGRP);
05385          write = !!(buf.st_mode & S_IWGRP);
05386          execute = !!(buf.st_mode & S_IXGRP);
05387        } else {
05388          read = !!(buf.st_mode & S_IROTH);
05389          write = !!(buf.st_mode & S_IWOTH);
05390          execute = !!(buf.st_mode & S_IXOTH);
05391        }
05392 #   else
05393        read = !!(buf.st_mode & (S_IRUSR | S_IRGRP | S_IROTH));
05394        write = !!(buf.st_mode & (S_IWUSR | S_IWGRP | S_IWOTH));
05395        execute = !!(buf.st_mode & (S_IXUSR | S_IXGRP | S_IXOTH));
05396 #   endif
05397        
05398        if (read)
05399          l = scheme_make_pair(read_symbol, l);
05400        if (write)
05401          l = scheme_make_pair(write_symbol, l);
05402        if (execute)
05403          l = scheme_make_pair(execute_symbol, l);
05404       }
05405     }
05406 #  endif  
05407 #  ifdef DOS_FILE_SYSTEM
05408   {
05409     int len = strlen(filename);
05410     int flags;
05411     
05412     if (UNC_stat(filename, len, &flags, NULL, NULL, NULL)) {
05413       if (flags & MZ_UNC_READ)
05414        l = scheme_make_pair(read_symbol, l);
05415       if (flags & MZ_UNC_WRITE)
05416        l = scheme_make_pair(write_symbol, l);
05417       if (flags & MZ_UNC_EXEC)
05418        l = scheme_make_pair(execute_symbol, l);
05419     } else
05420       l = NULL;
05421   }
05422 #  endif
05423 # endif
05424   
05425   if (!l) {
05426     scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
05427                    "file-or-directory-permissions: file or directory not found: \"%q\"",
05428                    filename_for_error(argv[0]));
05429   }
05430 
05431   return l;
05432 }
05433 
05434 static Scheme_Object *file_size(int argc, Scheme_Object *argv[])
05435 {
05436   char *filename;
05437   mzlonglong len = 0;
05438 
05439   if (!SCHEME_PATH_STRINGP(argv[0]))
05440     scheme_wrong_type("file-size", SCHEME_PATH_STRING_STR, 0, argc, argv);
05441 
05442   filename = scheme_expand_string_filename(argv[0],
05443                                       "file-size",
05444                                       NULL,
05445                                       SCHEME_GUARD_FILE_READ);
05446 
05447 #ifdef DOS_FILE_SYSTEM
05448  {
05449    if (UNC_stat(filename, strlen(filename), NULL, NULL, NULL, &len)) {
05450      return scheme_make_integer_value_from_long_long(len);
05451    }
05452  }
05453 #else
05454   {
05455     struct BIG_OFF_T_IZE(stat) buf;
05456 
05457     while (1) {
05458       if (!BIG_OFF_T_IZE(stat)(MSC_WIDE_PATH(filename), &buf))
05459        break;
05460       else if (errno != EINTR)
05461        goto failed;
05462     }
05463 
05464     if (S_ISDIR(buf.st_mode))
05465       goto failed;
05466 
05467     len = buf.st_size;
05468   }
05469 
05470   return scheme_make_integer_value_from_long_long(len);
05471 
05472  failed:
05473 #endif
05474 
05475   scheme_raise_exn(MZEXN_FAIL_FILESYSTEM,
05476                  "file-size: file not found: \"%q\"",
05477                  filename_for_error(argv[0]));
05478   return NULL;
05479 }
05480 
05481 #endif
05482 
05483 #ifdef DIR_FUNCTION
05484 
05485 static Scheme_Object *cwd_check(int argc, Scheme_Object **argv)
05486 {
05487   if (!SCHEME_PATH_STRINGP(argv[0])) {
05488     return NULL;
05489   } else {
05490     char *expanded;
05491     Scheme_Object *ed;
05492 
05493     expanded = scheme_expand_string_filename(argv[0], "current-directory", NULL, SCHEME_GUARD_FILE_EXISTS);
05494     ed = scheme_make_sized_path(expanded, strlen(expanded), 1);
05495 
05496 # ifndef NO_FILE_SYSTEM_UTILS
05497     ed = do_simplify_path(ed, scheme_null, 0, 1, 0, SCHEME_PLATFORM_PATH_KIND);
05498 # endif
05499 
05500     ed = scheme_path_to_directory_path(ed);
05501 
05502     return ed;
05503   }
05504 }
05505 
05506 static Scheme_Object *current_directory(int argc, Scheme_Object **argv)
05507 {
05508   if (!argc)
05509     scheme_security_check_file("current-directory", NULL, SCHEME_GUARD_FILE_EXISTS);
05510 
05511   return scheme_param_config("current-directory",
05512                           scheme_make_integer(MZCONFIG_CURRENT_DIRECTORY),
05513                           argc, argv,
05514                           -1, cwd_check, 
05515                           "complete path or string", 1);
05516 }
05517 
05518 #endif
05519 
05520 static Scheme_Object *collpaths_gen_p(int argc, Scheme_Object **argv, int rel)
05521 {
05522   Scheme_Object *v = argv[0];
05523 
05524   if (scheme_proper_list_length(v) < 0)
05525     return NULL;
05526 
05527   if (SCHEME_NULLP(v))
05528     return v;
05529 
05530   while (SCHEME_PAIRP(v)) {
05531     Scheme_Object *s;
05532     s = SCHEME_CAR(v);
05533     if (!SCHEME_PATH_STRINGP(s))
05534       return NULL;
05535     s = TO_PATH(s);
05536     if (rel && !scheme_is_relative_path(SCHEME_PATH_VAL(s),
05537                                    SCHEME_PATH_LEN(s),
05538                                         SCHEME_PLATFORM_PATH_KIND))
05539       return NULL;
05540     if (!rel && !scheme_is_complete_path(SCHEME_PATH_VAL(s),
05541                                     SCHEME_PATH_LEN(s),
05542                                          SCHEME_PLATFORM_PATH_KIND))
05543       return NULL;
05544     v = SCHEME_CDR(v);
05545   }
05546 
05547   if (!SCHEME_NULLP(v))
05548     return NULL;
05549 
05550   /* Convert to list of paths: */
05551   {
05552     Scheme_Object *last = NULL, *first = NULL, *p, *s;
05553     v = argv[0];
05554     while (SCHEME_PAIRP(v)) {
05555       s = SCHEME_CAR(v);
05556       s = TO_PATH(s);
05557       
05558       p = scheme_make_pair(s, scheme_null);
05559       if (!first)
05560        first = p;
05561       else
05562        SCHEME_CDR(last) = p;
05563       last = p;
05564 
05565       v = SCHEME_CDR(v);
05566     }
05567 
05568     return first;
05569   }
05570 }
05571 
05572 #ifndef NO_FILE_SYSTEM_UTILS
05573 
05574 static Scheme_Object *collpaths_p(int argc, Scheme_Object **argv)
05575 {
05576   return collpaths_gen_p(argc, argv, 0);
05577 }
05578 
05579 Scheme_Object *scheme_current_library_collection_paths(int argc, Scheme_Object *argv[]) {
05580   return current_library_collection_paths(argc, argv);
05581 }
05582 
05583 static Scheme_Object *current_library_collection_paths(int argc, Scheme_Object *argv[])
05584 {
05585   return scheme_param_config("current-library-collection-paths", 
05586                           scheme_make_integer(MZCONFIG_COLLECTION_PATHS),
05587                           argc, argv,
05588                           -1, collpaths_p, "list of complete paths and strings", 1);
05589 }
05590 
05591 #endif
05592 
05593 static Scheme_Object *compiled_kind_p(int argc, Scheme_Object **argv)
05594 {
05595   return collpaths_gen_p(argc, argv, 1);
05596 }
05597 
05598 static Scheme_Object *use_compiled_kind(int argc, Scheme_Object *argv[])
05599 {
05600   return scheme_param_config("use-compiled-file-paths",
05601                           scheme_make_integer(MZCONFIG_USE_COMPILED_KIND),
05602                           argc, argv,
05603                           -1, compiled_kind_p, "list of relative paths and strings", 1);
05604 }
05605 
05606 static Scheme_Object *use_user_paths(int argc, Scheme_Object *argv[])
05607 {
05608   return scheme_param_config("use-user-specific-search-paths", 
05609                           scheme_make_integer(MZCONFIG_USE_USER_PATHS),
05610                           argc, argv,
05611                           -1, NULL, NULL, 1);
05612 }
05613 
05614 /********************************************************************************/
05615 
05616 #ifndef NO_FILE_SYSTEM_UTILS
05617 
05618 enum {
05619   id_temp_dir,
05620   id_home_dir,
05621   id_doc_dir,
05622   id_desk_dir,
05623   id_pref_dir,
05624   id_pref_file,
05625   id_init_dir,
05626   id_init_file,
05627   id_sys_dir,
05628   id_addon_dir
05629 };
05630 
05631 Scheme_Object *scheme_get_run_cmd(void)
05632 {
05633   if (!run_cmd) {
05634     REGISTER_SO(run_cmd);
05635     run_cmd = scheme_make_path("mzscheme");
05636   }
05637   return run_cmd;
05638 }
05639 
05640 static Scheme_Object *
05641 find_system_path(int argc, Scheme_Object **argv)
05642 {
05643   int which;
05644 
05645   if (argv[0] == temp_dir_symbol)
05646     which = id_temp_dir;
05647   else if (argv[0] == home_dir_symbol)
05648     which = id_home_dir;
05649   else if (argv[0] == doc_dir_symbol)
05650     which = id_doc_dir;
05651   else if (argv[0] == desk_dir_symbol)
05652     which = id_desk_dir;
05653   else if (argv[0] == pref_dir_symbol)
05654     which = id_pref_dir;
05655   else if (argv[0] == init_dir_symbol)
05656     which = id_init_dir;
05657   else if (argv[0] == pref_file_symbol)
05658     which = id_pref_file;
05659   else if (argv[0] == init_file_symbol)
05660     which = id_init_file;
05661   else if (argv[0] == sys_dir_symbol)
05662     which = id_sys_dir;
05663   else if (argv[0] == exec_file_symbol) {
05664     if (!exec_cmd) {
05665       REGISTER_SO(exec_cmd);
05666       exec_cmd = scheme_make_path("mzscheme");
05667     }
05668     return exec_cmd;
05669   } else if (argv[0] == run_file_symbol) {
05670     return scheme_get_run_cmd();
05671   } else if (argv[0] == collects_dir_symbol) {
05672     if (!collects_path) {
05673       REGISTER_SO(collects_path);
05674       collects_path = scheme_make_path("collects");
05675     }
05676     return collects_path;
05677   } else if (argv[0] == orig_dir_symbol) {
05678     return original_pwd;
05679   } else if (argv[0] == addon_dir_symbol) {
05680     which = id_addon_dir;
05681   } else {
05682     scheme_wrong_type("find-system-path", "system-path-symbol",
05683                     0, argc, argv);
05684     return NULL;
05685   }
05686 
05687   scheme_security_check_file("find-system-path", NULL, SCHEME_GUARD_FILE_EXISTS);
05688 
05689 #ifdef UNIX_FILE_SYSTEM
05690   if (which == id_sys_dir) {
05691     return scheme_make_path("/");
05692   }
05693 
05694   if (which == id_temp_dir) {
05695     char *p;
05696     
05697     if ((p = getenv("TMPDIR"))) {
05698       p = scheme_expand_filename(p, -1, NULL, NULL, 0);
05699       if (p && scheme_directory_exists(p))
05700        return scheme_make_path(p);
05701     }
05702 
05703     if (scheme_directory_exists("/var/tmp"))
05704       return scheme_make_path("/var/tmp");
05705 
05706     if (scheme_directory_exists("/usr/tmp"))
05707       return scheme_make_path("/usr/tmp");
05708 
05709     if (scheme_directory_exists("/tmp"))
05710       return scheme_make_path("/tmp");
05711 
05712     return CURRENT_WD();
05713   }
05714   
05715   {
05716     /* Everything else is in ~: */
05717     Scheme_Object *home;
05718     char *home_str, *ex_home;
05719     int ends_in_slash;
05720 
05721     if ((which == id_pref_dir) 
05722        || (which == id_pref_file)
05723        || (which == id_addon_dir)) {
05724 #if defined(OS_X) && !defined(XONX)
05725       if (which == id_addon_dir)
05726        home_str = "~/Library/PLT Scheme/";
05727       else
05728        home_str = "~/Library/Preferences/";
05729 #else
05730       home_str = "~/.plt-scheme/";
05731 #endif 
05732     } else {
05733 #if defined(OS_X) && !defined(XONX)
05734       if (which == id_desk_dir)
05735        home_str = "~/Desktop/";
05736       else if (which == id_doc_dir)
05737        home_str = "~/Documents/";
05738       else
05739 #endif
05740         home_str = "~/";
05741     }
05742     
05743     ex_home = do_expand_filename(NULL, home_str, strlen(home_str), NULL,
05744                                  NULL,
05745                                  0, 1,
05746                                  0, SCHEME_UNIX_PATH_KIND, 
05747                                  1);
05748 
05749     if (!ex_home) {
05750       /* Something went wrong with the user lookup. Just drop "~'. */
05751       home = scheme_make_sized_offset_path(home_str, 1, -1, 1);
05752     } else
05753       home = scheme_make_path(ex_home);
05754 
05755     
05756     if ((which == id_pref_dir) || (which == id_init_dir) 
05757        || (which == id_home_dir) || (which == id_addon_dir)
05758        || (which == id_desk_dir) || (which == id_doc_dir))
05759       return home;
05760 
05761     ends_in_slash = (SCHEME_PATH_VAL(home))[SCHEME_PATH_LEN(home) - 1] == '/';
05762     
05763     if (which == id_init_file)
05764       return append_path(home, scheme_make_path("/.mzschemerc" + ends_in_slash));
05765     if (which == id_pref_file) {
05766 #if defined(OS_X) && !defined(XONX)
05767       return append_path(home, scheme_make_path("/org.plt-scheme.prefs.ss" + ends_in_slash));
05768 #else      
05769       return append_path(home, scheme_make_path("/plt-prefs.ss" + ends_in_slash));
05770 #endif
05771     }
05772   }
05773 #endif
05774 
05775 #ifdef DOS_FILE_SYSTEM
05776   if (which == id_sys_dir) {
05777     int size;
05778     wchar_t *s;
05779     size = GetSystemDirectoryW(NULL, 0);
05780     s = (wchar_t *)scheme_malloc_atomic((size + 1) * sizeof(wchar_t));
05781     GetSystemDirectoryW(s, size + 1);
05782     return scheme_make_path(NARROW_PATH(s));
05783   }
05784 
05785   {
05786     char *d, *p;
05787     Scheme_Object *home;
05788     int ends_in_slash;
05789     
05790     if (which == id_temp_dir) {
05791       if ((p = getenv("TMP")) || (p = getenv("TEMP"))) {
05792        p = scheme_expand_filename(p, -1, NULL, NULL, 0);
05793        if (p && scheme_directory_exists(p))
05794          return scheme_make_path(p);
05795       }
05796       
05797       return CURRENT_WD();
05798     }
05799 
05800     home = NULL;
05801 
05802     {
05803       /* Try to get Application Data directory: */
05804       LPITEMIDLIST items;
05805       int which_folder;
05806 
05807       if ((which == id_addon_dir)
05808          || (which == id_pref_dir)
05809          || (which == id_pref_file)) 
05810        which_folder = CSIDL_APPDATA;
05811       else if (which == id_doc_dir) {
05812 #       ifndef CSIDL_PERSONAL
05813 #         define CSIDL_PERSONAL 0x0005
05814 #       endif
05815        which_folder = CSIDL_PERSONAL;
05816       } else if (which == id_desk_dir)    
05817        which_folder = CSIDL_DESKTOPDIRECTORY;
05818       else {
05819 #       ifndef CSIDL_PROFILE
05820 #         define CSIDL_PROFILE 0x0028
05821 #       endif
05822        which_folder = CSIDL_PROFILE;
05823       }
05824 
05825       if (SHGetSpecialFolderLocation(NULL, which_folder, &items) == S_OK) {
05826        int ok;
05827        IMalloc *mi;
05828        wchar_t *buf;
05829 
05830        buf = (wchar_t *)scheme_malloc_atomic(MAX_PATH * sizeof(wchar_t));
05831        ok = SHGetPathFromIDListW(items, buf);
05832 
05833        SHGetMalloc(&mi);
05834        mi->lpVtbl->Free(mi, items);
05835        mi->lpVtbl->Release(mi);
05836 
05837        if (ok) {
05838          home = scheme_make_path_without_copying(NARROW_PATH(buf));
05839        }
05840       }
05841     }
05842 
05843     if (!home) {
05844       /* Back-up: try USERPROFILE environment variable */
05845       d = getenv("USERPROFILE");
05846       if (d) {
05847        if (scheme_directory_exists(d))
05848          home = scheme_make_path_without_copying(d);
05849       }
05850     }
05851 
05852     if (!home) {
05853     /* Last-ditch effort: try HOMEDRIVE+HOMEPATH */
05854       d = getenv("HOMEDRIVE");
05855       p = getenv("HOMEPATH");
05856 
05857       if (d && p) {
05858        char *s;
05859        s = scheme_malloc_atomic(strlen(d) + strlen(p) + 1);
05860        strcpy(s, d);
05861        strcat(s, p);
05862       
05863        if (scheme_directory_exists(s))
05864          home = scheme_make_path_without_copying(s);
05865        else
05866          home = NULL;
05867       } else 
05868        home = NULL;
05869     
05870       if (!home) {
05871        wchar_t name[1024];
05872       
05873        if (!GetModuleFileNameW(NULL, name, 1024)) {
05874          /* Disaster. Use CWD. */
05875          home = CURRENT_WD();
05876        } else {
05877          int i;
05878          wchar_t *s;
05879        
05880          s = name;
05881        
05882          i = wc_strlen(s) - 1;
05883        
05884          while (i && (s[i] != '\\')) {
05885            --i;
05886          }
05887          s[i] = 0;
05888          home = scheme_make_path(NARROW_PATH(s));
05889        }
05890       }
05891     }
05892     
05893     if ((which == id_init_dir)
05894        || (which == id_home_dir)
05895        || (which == id_doc_dir)
05896        || (which == id_desk_dir))
05897       return home;
05898 
05899     ends_in_slash = (SCHEME_PATH_VAL(home))[SCHEME_PATH_LEN(home) - 1];
05900     ends_in_slash = ((ends_in_slash == '/') || (ends_in_slash == '\\'));
05901 
05902     if ((which == id_addon_dir)
05903        || (which == id_pref_dir)
05904        || (which == id_pref_file)) {
05905       home = append_path(home, scheme_make_path("\\PLT Scheme" + ends_in_slash));
05906       ends_in_slash = 0;
05907     }
05908 
05909     if (which == id_init_file)
05910       return append_path(home, scheme_make_path("\\mzschemerc.ss" + ends_in_slash));
05911     if (which == id_pref_file)
05912       return append_path(home, scheme_make_path("\\plt-prefs.ss" + ends_in_slash));
05913     return home;
05914   }
05915 #endif
05916 
05917   /* Something went wrong if we get here. */
05918   return scheme_void;
05919 }
05920 
05921 #endif
05922 
05923 Scheme_Object *scheme_set_exec_cmd(char *s)
05924 {
05925 #ifndef NO_FILE_SYSTEM_UTILS
05926   if (!exec_cmd) {
05927     REGISTER_SO(exec_cmd);
05928     exec_cmd = scheme_make_path(s);
05929   }
05930 
05931   return exec_cmd;
05932 #endif
05933 }
05934 
05935 Scheme_Object *scheme_set_run_cmd(char *s)
05936 {
05937 #ifndef NO_FILE_SYSTEM_UTILS
05938   if (!run_cmd) {
05939     REGISTER_SO(run_cmd);
05940     run_cmd = scheme_make_path(s);
05941   }
05942 
05943   return run_cmd;
05944 #endif
05945 }
05946 
05947 char *scheme_get_exec_path(void)
05948 {
05949   if (exec_cmd)
05950     return SCHEME_PATH_VAL(exec_cmd);
05951   else
05952     return NULL;
05953 }
05954 
05955 void scheme_set_collects_path(Scheme_Object *p)
05956 {
05957   REGISTER_SO(collects_path);
05958   collects_path = p;
05959 }
05960 
05961 void scheme_set_original_dir(Scheme_Object *d)
05962 {
05963   if (!original_pwd) {
05964     REGISTER_SO(original_pwd);
05965   }
05966   original_pwd = d;
05967 }
05968 
05969 /********************************************************************************/
05970 
05971 #ifdef DOS_FILE_SYSTEM
05972 
05973 static wchar_t *dlldir;
05974 
05975 __declspec(dllexport) wchar_t *scheme_get_dll_path(wchar_t *s);
05976 __declspec(dllexport) void scheme_set_dll_path(wchar_t *p);
05977 
05978 wchar_t *scheme_get_dll_path(wchar_t *s)
05979 {
05980   if (dlldir) {
05981     int len1, len2;
05982     wchar_t *p;
05983     len1 = wc_strlen(dlldir);
05984     len2 = wc_strlen(s);
05985     p = (wchar_t *)scheme_malloc_atomic((len1 + len2 + 2) * sizeof(wchar_t));
05986     memcpy(p, dlldir, len1 * sizeof(wchar_t));
05987     if (p[len1 - 1] != '\\') {
05988       p[len1++] = '\\';
05989     }
05990     memcpy(p + len1, s, (len2 + 1) * sizeof(wchar_t));
05991     return p;
05992   } else
05993     return s;
05994 }
05995 
05996 void scheme_set_dll_path(wchar_t *p)
05997 {
05998   dlldir = p;
05999 }
06000 
06001 #endif