/src/pathname.d

Large files files are truncated, but you can click here to view the full file

/*
 * Pathnames for CLISP
 * Bruno Haible 1990-2005
 * Logical Pathnames: Marcus Daniels 16.9.1994
 * ANSI compliance, bugs: Sam Steingold 1998-2008
 * German comments translated into English: Stefan Kain 2002-01-03
 */

#include "lispbibl.c"
#ifdef WIN32_NATIVE
#include "w32shell.c"
#endif
#include <string.h> /* declares strlen() */

/* enable the following #define to debug pathname translations
 setting DEBUG_TRANSLATE_PATHNAME to a larger value results in more output
 WARNING: PRIN1 can trigger GC! BEWARE!
 define DEBUG_TRANSLATE_PATHNAME 1 */
#if DEBUG_TRANSLATE_PATHNAME
#define string_concat(x) (printf("[%d]string_concat(%d)\n",__LINE__,x),(string_concat)(x))
#define DOUT(label,obj)  OBJECT_OUT(obj,label)
#define SDOUT(label,obj) printf("%d %s %s",__LINE__,label,STRING(obj));nobject_out(stdout,obj)
#else
#define DOUT(l,o)
#define SDOUT(l,o)
#endif

/* ========================================================================
                       Low level functions */

/* UP: Tests whether a pathname is possibly a symlink.
 possible_symlink(path) */
#ifdef UNIX_LINUX
local inline bool possible_symlink (const char* path) {
  /* In Linux 2.0.35, /proc/<pid>/{cwd,exe,root} and /proc/<pid>/fd/<n>
   are symlinks pointing to void. Treat them like non-symlinks, in order
   to avoid errors. */
  if (path[0]=='/'
      && path[1]=='p' && path[2]=='r' && path[3]=='o' && path[4]=='c'
      && path[5]=='/'
      && (path[6]>='0' && path[6]<='9'))
    return false;
  return true;
}
#else
  #define possible_symlink(path)  true
#endif

#ifdef UNIX_LINUX
/* The Linux /proc filesystem has some symlinks whose readlink value is
 zero-terminated: /proc/self in Linux 2.0.35, /proc/<pid>/fd/<n> in
 Linux 2.2.2. Remove this extraneous trailing zero byte. */
local inline int my_readlink (const char* path, char* buf, size_t bufsiz) {
  var int linklen = readlink(path,buf,bufsiz);
  if (linklen > 0 && buf[linklen-1] == '\0')
    linklen--;
  return linklen;
}
#define readlink  my_readlink
#endif

/* we need realpath() (declared in <stdlib.h>, included under STDC_HEADERS)
   http://www.opengroup.org/onlinepubs/009695399/functions/realpath.html
   which is alleged to be broken on some systems
   OTOH, on some other systems, notably on cygwin,
   we _do_ need the system implementation of realpath
   because otherwise we get screwed on /proc/self/exe -> lisp
   instead of lisp.exe and possibly other quirks */
#if defined(UNIX) && !defined(HAVE_REALPATH)
  /* library-function realpath implementation:
   [Copyright: SUN Microsystems, B. Haible]
   TITLE
     REALPATH(3)
   SYNOPSIS
     char* realpath (const char* path, char resolved_path[MAXPATHLEN]);
   DESCRIPTION
     realpath() expands all symbolic links  and  resolves  refer-
     ences  to '/./', '/../' and extra '/' characters in the null
     terminated string named by path and stores the canonicalized
     absolute pathname in the buffer named by resolved_path.  The
     resulting path will have no symbolic links  components,  nor
     any '/./' or '/../' components.
   RETURN VALUES
     realpath() returns a pointer to the  resolved_path  on  suc-
     cess.   On  failure, it returns NULL, sets errno to indicate
     the error, and places in resolved_path the absolute pathname
     of the path component which could not be resolved. */
#define realpath my_realpath /* avoid conflict with Consensys realpath declaration */
local char* realpath (const char* path, char* resolved_path) {
  /* Method: use getwd and readlink. */
  var char mypath[MAXPATHLEN];
  var int symlinkcount = 0; /* the number of symbolic links so far */
  var char* resolved_limit = &resolved_path[MAXPATHLEN-1];
  /* Valid pointers are those with resolved_path <= ptr <= resolved_limit.
   in *resolved_limit at most one null byte.
   (similarly with mypath.) */
  var char* resolve_start;
  {
    var char* resolved_ptr = resolved_path; /* always <= resolved_limit */
    /* poss. use Working-Directory: */
    if (!(path[0]=='/')) { /* not an absolute pathname? */
      if (getwd(resolved_path) == NULL)
        return NULL;
      resolved_ptr = resolved_path;
      while (*resolved_ptr) {
        resolved_ptr++;
      }
      if (resolved_ptr < resolved_limit) {
        *resolved_ptr++ = '/';
      }
      resolve_start = resolved_ptr;
    } else {
      resolve_start = resolved_ptr = &resolved_path[0];
    }
    /* copy the path: */
    var const char* path_ptr = path;
    while ((resolved_ptr < resolved_limit) && *path_ptr) {
      *resolved_ptr++ = *path_ptr++;
    }
    /* finish with '/' and a null: */
    if (resolved_ptr < resolved_limit) {
      *resolved_ptr++ = '/';
    }
    *resolved_ptr = 0;
  }
  /* Now start in resolved_path at resolve_start. */
  var char* from_ptr = resolve_start;
  var char* to_ptr = resolve_start;
  while ((to_ptr < resolved_limit) && (*from_ptr)) {
    /* so far the path in  resolved_path[0]...to_ptr[-1]
     has the shape '/subdir1/subdir2/.../txt',
     whereas 'txt' is poss. empty, but no subdir is empty. */
    var char next = *from_ptr++; *to_ptr++ = next;
    if ((next == '/') && (to_ptr > resolved_path+1)) {
      /* to_ptr[-1]='/'  ->  resolve Directory ...to_ptr[-2] : */
      var char* last_subdir_end = &to_ptr[-2];
      switch (*last_subdir_end) {
        case '/':
          #ifdef PATHNAME_UNIX_UNC
          if (to_ptr > resolved_path+2)
          #endif
            /* '//' is simplified to '/' : */
            to_ptr--;
          break;
        case '.':
          {
            var char* last_subdir_ptr = &last_subdir_end[-1];
            if (to_ptr > resolved_path+2) {
              if (*last_subdir_ptr == '.') {
                if ((to_ptr > resolved_path+4)
                    && (*--last_subdir_ptr == '/')) {
                  /* last subdir was '/../'
                   Therefore remove the subdir in front of it: */
                  while ((last_subdir_ptr > resolved_path)
                         && !(*--last_subdir_ptr == '/'));
                  to_ptr = last_subdir_ptr+1;
                }
              } else if (*last_subdir_ptr == '/') {
                /* last subdir was '/./'
                 remove: */
                to_ptr = last_subdir_end;
              }
            }
          }
          break;
        default:
          /* after a normal subdir */
          #ifdef HAVE_READLINK
          if (possible_symlink(resolved_path)) {
            /* read symbolic link: */
            to_ptr[-1]=0; /* replace '/' with 0 */
            #ifdef UNIX_CYGWIN32
            /* readlink() does not work right on NFS mounted directories
             (it returns -1,ENOENT or -1,EIO).
             So check for a directory first. */
            var struct stat statbuf;
            if (lstat(resolved_path,&statbuf) < 0)
              return NULL; /* error */
            if (S_ISDIR(statbuf.st_mode)) {
              /* directory, not a symbolic link */
              to_ptr[-1] = '/'; /* insert the '/' again */
            } else if (!S_ISLNK(statbuf.st_mode)) {
              /* something else, but not a directory or symbolic link. */
              errno = ENOTDIR;
              return NULL;
            } else
            #endif
              {
                var int linklen =
                  readlink(resolved_path,mypath,sizeof(mypath)-1);
                if (linklen >=0) { /* was a symbolic link */
                  if (++symlinkcount > MAXSYMLINKS) {
                    errno = ELOOP_VALUE; return NULL;
                  }
                  { /* append the still to be resolved part of path
                   to the link-content: */
                    var char* mypath_ptr = &mypath[linklen]; /* here is room */
                    var char* mypath_limit = &mypath[MAXPATHLEN-1]; /* up to here */
                    if (mypath_ptr < mypath_limit) { *mypath_ptr++ = '/'; } /* first, append a '/' */
                    /* then the rest: */
                    while ((mypath_ptr <= mypath_limit)
                           && (*mypath_ptr = *from_ptr++))
                      { mypath_ptr++; }
                    *mypath_ptr = 0; /* and conclude wit 0 */
                  }
                  /* this replaces resp. completes the path: */
                  if (mypath[0] == '/') { /* replaces the path: */
                    from_ptr = &mypath[0]; to_ptr = resolved_path;
                    while ((*to_ptr++ = *from_ptr++));
                    from_ptr = resolved_path;
                  } else { /* completes the path:
                     disrcard link-name. Therefore search for the last '/': */
                    {
                      var char* ptr = &to_ptr[-1];
                      while ((ptr > resolved_path) && !(ptr[-1] == '/')) { ptr--; }
                      from_ptr = ptr;
                    }
                    {
                      var char* mypath_ptr = &mypath[0]; to_ptr = from_ptr;
                      while ((to_ptr <= resolved_limit) && (*to_ptr++ = *mypath_ptr++));
                    }
                  }
                  to_ptr = from_ptr;
                } else {
                  #if defined(UNIX_IRIX)
                  if ((errno == EINVAL) || (errno == ENXIO))
                  #elif defined(UNIX_CYGWIN32)
                  if ((errno == EINVAL) || (errno == EACCES))
                  #else
                  if (errno == EINVAL)
                  #endif
                    /* no symbolic link */
                    to_ptr[-1] = '/'; /* insert the '/' again */
                  else
                    return NULL; /* error */
                }
              }
          }
          #endif
          break;
      }
    }
  } /* go for the next subdir */
  /* discard a '/' at the tail: */
  if ((to_ptr[-1] == '/')
      #ifdef PATHNAME_UNIX_UNC
      && (to_ptr > resolved_path+2)
      #else
      && (to_ptr > resolved_path+1)
      #endif
      )
    to_ptr--;
  to_ptr[0] = 0; /* conclude with 0 */
  return resolved_path; /* finished */
}
#endif

/* Creates a new subdirectory.
 make_directory(pathstring);
 > pathstring: result of shorter_directory(...)
 > STACK_0: pathname */
local inline void make_directory (char* pathstring) {
 #ifdef UNIX
  begin_system_call();
  if (mkdir(pathstring,0777)) { /* create sub-directory */
    end_system_call(); OS_file_error(STACK_0);
  }
  end_system_call();
 #endif
 #ifdef WIN32_NATIVE
  begin_system_call();
  if (! CreateDirectory(pathstring,NULL) ) { /* create sub-directory */
    end_system_call(); OS_file_error(STACK_0);
  }
  end_system_call();
 #endif
}

/* Deletes a subdirectory.
 delete_directory(pathstring);
 > pathstring: result of shorter_directory(...)
 > STACK_0: pathname */
local inline void delete_directory (char* pathstring) {
 #ifdef UNIX
  begin_system_call();
  if (rmdir(pathstring)) { /* delete sub-directory */
    end_system_call(); OS_file_error(STACK_0);
  }
  end_system_call();
 #endif
 #ifdef WIN32_NATIVE
  begin_system_call();
  if (! RemoveDirectory(pathstring) ) { /* delete sub-directory */
    end_system_call(); OS_file_error(STACK_0);
  }
  end_system_call();
 #endif
}

#ifdef WIN32_NATIVE
/* Changes the operating system's current directory.
 change_directory(pathstring);
 > pathstring: directory, ASCIZ-String
 > STACK_0: pathname */
local inline void change_current_directory (char* pathstring) {
  begin_system_call();
  if (!SetCurrentDirectory(pathstring)) {
    end_system_call(); OS_file_error(STACK_0);
  }
  end_system_call();
}
#endif

/* Delete a file.
 delete_existing_file(pathstring);
 It is known that the file exists.
 > pathstring: file name, ASCIZ-String
 > STACK_0: pathname */
local inline void delete_existing_file (char* pathstring) {
 #ifdef UNIX
  begin_system_call();
  if (!( unlink(pathstring) ==0)) {
    end_system_call(); OS_file_error(STACK_0);
  }
  end_system_call();
 #endif
 #ifdef WIN32_NATIVE
  begin_system_call();
  if (! DeleteFile(pathstring) ) {
    end_system_call(); OS_file_error(STACK_0);
  }
  end_system_call();
 #endif
}

#ifdef WIN32_NATIVE
#define WIN32_ERROR_NOT_FOUND (GetLastError()==ERROR_FILE_NOT_FOUND || GetLastError()==ERROR_PATH_NOT_FOUND || GetLastError()==ERROR_BAD_NETPATH)
#endif

/* Delete a file.
 delete_file_if_exists(pathstring);
 No error is signaled if the file does not exist.
 > pathstring: file name, ASCIZ-String
 > STACK_0: pathname
 < result: whether the file existed */
local inline bool delete_file_if_exists (char* pathstring) {
  var bool exists = true;
 #ifdef UNIX
  begin_system_call();
  if (!( unlink(pathstring) ==0)) {
    if (!(errno==ENOENT)) { /* not found -> OK */
      end_system_call(); OS_file_error(STACK_0); /* report other error */
    }
    exists = false;
  }
  end_system_call();
 #endif
 #ifdef WIN32_NATIVE
  begin_system_call();
  if (! DeleteFile(pathstring) ) {
    if (!WIN32_ERROR_NOT_FOUND) {
      end_system_call(); OS_file_error(STACK_0);
    }
    exists = false;
  }
  end_system_call();
 #endif
  return exists;
}
local bool delete_file_if_exists_obj (object namestring) {
  bool ret;
  with_sstring_0(namestring,O(pathname_encoding),namestring_asciz, {
    ret = delete_file_if_exists(namestring_asciz);
  });
  return ret;
}

/* Delete a file being the target of a subsequent rename.
 delete_file_before_rename(pathstring);
 No error is signaled if the file does not exist.
 > pathstring: file name, ASCIZ-String
 > STACK_0: pathname */
local inline void delete_file_before_rename (char* pathstring) {
 #if !defined(UNIX) /* rename() on Unix does it automatically */
  delete_file_if_exists(pathstring);
 #endif
}

/* Rename a file.
 rename_existing_file(old_pathstring,new_pathstring);
 It is known that the old_pathstring exists.
 On platforms except UNIX, it is known that new_pathstring does not exist.
 > old_pathstring: old file name, ASCIZ-String
 > new_pathstring: new file name, ASCIZ-String
 > STACK_0: pathname */
local inline void rename_existing_file (char* old_pathstring,
                                        char* new_pathstring) {
 #ifdef UNIX
  begin_system_call();
  if ( rename(old_pathstring,new_pathstring) <0) { /* rename file */
    end_system_call(); OS_file_error(STACK_0); /* report error */
  }
  end_system_call();
 #endif
 #ifdef WIN32_NATIVE
  begin_system_call();
  if (! MoveFile(old_pathstring,new_pathstring) ) {
    end_system_call(); OS_file_error(STACK_0);
  }
  end_system_call();
 #endif
}

/* ========================================================================
                         P A T H N A M E S

 All simple-strings occurring in pathnames are in fact
 normal-simple-strings.

#ifdef PATHNAME_UNIX
 Components:
 HOST          always NIL
 DEVICE        always NIL
 DIRECTORY     (Startpoint . Subdirs) whereas
                Startpoint = :RELATIVE | :ABSOLUTE
                Subdirs = () | (subdir . Subdirs)
                subdir = :WILD-INFERIORS (means "**" or "...", all subdirectories) or
                subdir = Simple-String, poss. with wildcard-character ? and *
 NAME          NIL or
               Simple-String, poss. with wildcard-character ? and *
               (also :WILD on input)
 TYPE          NIL or
               Simple-String, poss. with wildcard-character ? and *
               (also :WILD on input)
 VERSION       always NIL (also :WILD or :NEWEST on input)
 A UNIX-filename is split in Name and Type as follows:
   if there is no '.' in Filename: Name = everything, Type = NIL,
   if there is '.' in Filename: Name = everything in front of it, Type = everything behind the last '.' .
 If a pathname must be completely specified (no wildcards),
  :WILD, :WILD-INFERIORS are not allowed, no wildcard-characters in the
 Strings, at NAME poss. also not NIL.
 External Notation:  server:/sub1.typ/sub2.typ/name.typ
 with Defaults:             /sub1.typ/sub2.typ/name.typ
 or                                            name.typ
 or                         /sub1.typ/ ** /sub3.typ/x*.lisp  (without Spaces!)
 or similar.
 If NAME starts with a dot, (parse-namestring (namestring pathname)) will not
 be the same as pathname.
#endif

#ifdef PATHNAME_WIN32
 Components:
 HOST          NIL or Simple-String (Wildcard-Characters are without meaning)
 DEVICE        NIL or :WILD or "A"|...|"Z"
 DIRECTORY     (Startpoint . Subdirs) whereas
                Startpoint = :RELATIVE | :ABSOLUTE
                Subdirs = () | (subdir . Subdirs)
                subdir = :WILD-INFERIORS (means "**" or "...", all Subdirectories) or
                subdir = Simple-String, poss. with Wildcard-Character ? and *
 NAME          NIL or
               Simple-String, poss. with Wildcard-Character ? and *
               (also :WILD on input)
 TYPE          NIL or
               Simple-String, poss. with Wildcard-Character ? and *
               (also :WILD on input)
 VERSION       always NIL (also :WILD or :NEWEST on input)
 If HOST is non-NIL, DEVICE must be NIL.
 A WIN32-Filename is split into Name and Type as follows:
   if there is no '.' in Filename: Name = everything, Type = NIL,
   if there is a '.' in Filename: Name = everything in front of, Type = everything behind the last '.' .
 If a Pathname must be completely specified (no Wildcards),
 then :WILD, :WILD-INFERIORS are not allowed, no Wildcard-Characters in the
 Strings, at NAME poss. also not NIL.
 External notation:       A:\sub1.typ\sub2.typ\name.typ
 with Defaults:             \sub1.typ\sub2.typ\name.typ
 or                                            name.typ
 or                       *:\sub1.typ\**\sub3.typ\x*.lisp
 or similar.
 Instead of '\'  - traditionally on DOS - also '/' is allowed.
 If HOST is non-NIL and the DIRECTORY's Startpoint is not :ABSOLUTE,
 (parse-namestring (namestring pathname)) will not be the same as pathname.
#endif

#ifdef LOGICAL_PATHNAMES
 Components of Logical Pathnames:
 HOST          Simple-String or NIL
 DEVICE        always NIL
 DIRECTORY     (Startpoint . Subdirs) whereas
                Startpoint = :RELATIVE | :ABSOLUTE
                Subdirs = () | (subdir . Subdirs)
               subdir = :WILD-INFERIORS (means "**", all Subdirectories) or
               subdir = :WILD (means "*") or
               subdir = Simple-String, poss. with Wildcard-Character *
 NAME          NIL or
               :WILD (means "*") or
               Simple-String, poss. with Wildcard-Character *
 TYPE          NIL or
               :WILD (means "*") or
               Simple-String, poss. with Wildcard-Character *
 VERSION       NIL or :NEWEST or :WILD or Integer
 External Notation: see CLtl2 p. 628-629.
#endif

 access functions without case transforms:
 xpathname_host(logical,pathname)
 xpathname_device(logical,pathname)
 xpathname_directory(logical,pathname)
 xpathname_name(logical,pathname)
 xpathname_type(logical,pathname)
 xpathname_version(logical,pathname)
 > pathname: pathname or logical pathname
 > logical: flag = logpathnamep(pathname)
 < result: the value of the requested component
 pathname_*_maybe return the appropriate slot seen from the point of view of the
 underlying physical file system, therefore, ever though pathname has the slot
 version (for ANSI compliance reasons), pathname_version_maybe() returns NIL */
#if HAS_HOST
#define pathname_host_maybe(obj) (object)ThePathname(obj)->pathname_host
#else
#define pathname_host_maybe(obj) (unused(obj), NIL)
#endif
#if HAS_DEVICE
#define pathname_device_maybe(obj) (object)ThePathname(obj)->pathname_device
#else
#define pathname_device_maybe(obj) (unused(obj), NIL)
#endif
#if HAS_VERSION
#define pathname_version_maybe(obj) (object)ThePathname(obj)->pathname_version
#else
#define pathname_version_maybe(obj) (unused(obj), NIL)
#endif

#ifdef LOGICAL_PATHNAMES
#define xpathname_host(logical,pathname)                       \
  (logical ? (object)TheLogpathname(pathname)->pathname_host : \
             pathname_host_maybe(pathname))
#define xpathname_device(logical,pathname)  \
  (logical ? NIL : pathname_device_maybe(pathname))
#define xpathname_directory(logical,pathname)                       \
  (logical ? (object)TheLogpathname(pathname)->pathname_directory : \
                (object)ThePathname(pathname)->pathname_directory)
#define xpathname_name(logical,pathname)                       \
  (logical ? (object)TheLogpathname(pathname)->pathname_name : \
                (object)ThePathname(pathname)->pathname_name)
#define xpathname_type(logical,pathname)                       \
  (logical ? (object)TheLogpathname(pathname)->pathname_type : \
                (object)ThePathname(pathname)->pathname_type)
#define xpathname_version(logical,pathname)                       \
  (logical ? (object)TheLogpathname(pathname)->pathname_version : \
                (object)ThePathname(pathname)->pathname_version)
#else /* no logical pathnames */
#define xpathname_host(logical,pathname) \
  pathname_host_maybe(pathname)
#define xpathname_device(logical,pathname) \
  pathname_device_maybe(pathname)
#define xpathname_directory(logical,pathname) \
  ThePathname(pathname)->pathname_directory
#define xpathname_name(logical,pathname) \
  ThePathname(pathname)->pathname_name
#define xpathname_type(logical,pathname) \
  ThePathname(pathname)->pathname_type
#define xpathname_version(logical,pathname) \
  ThePathname(pathname)->pathname_version
#endif

#define SUBST_RECURSE(atom_form,self_call)                      \
  if (atomp(obj)) return atom_form;                             \
  check_STACK(); check_SP();                                    \
  pushSTACK(obj);                                               \
  { /* recursive call for CAR: */                               \
    object new_car = self_call(Car(obj));                       \
    pushSTACK(new_car);                                         \
  }                                                             \
  { /* recursive call for CDR: */                               \
    object new_cdr = self_call(Cdr(STACK_1));                   \
    if (eq(new_cdr,Cdr(STACK_1)) && eq(STACK_0,Car(STACK_1))) { \
      obj = STACK_1; skipSTACK(2); return obj;                  \
    } else { /* (CONS new_car new_cdr) */                       \
      STACK_1 = new_cdr;                                        \
     {object new_cons = allocate_cons();                        \
      Car(new_cons) = popSTACK(); Cdr(new_cons) = popSTACK();   \
      return new_cons;                                          \
    }}                                                          \
  }

/* Converts capital-/small letters between :LOCAL and :COMMON .
 common_case(string)
 > string: Normal-Simple-String or Symbol/Number
 < result: converted Normal-Simple-String or the same Symbol/Number
 can trigger GC
 Operating System with preference for small letters or Capitalize */
local maygc object common_case (object string) {
  if (!simple_string_p(string))
    return string;
  var uintL len = Sstring_length(string);
  /* Search, if capital- or small letters (or both) occur: */
  var bool all_upper = true;
  var bool all_lower = true;
  if (len > 0) {
    var object storage = string; sstring_un_realloc(storage);
    SstringDispatch(storage,X, {
      var const cintX* ptr = &((SstringX)TheVarobject(storage))->data[0];
      var uintL count;
      dotimespL(count,len, {
        var chart ch = as_chart(*ptr++);
        if (!chareq(ch,up_case(ch)))
          all_upper = false;
        if (!chareq(ch,down_case(ch)))
          all_lower = false;
        if (!all_upper && !all_lower)
          break;
      });
    });
  }
  if (all_upper == all_lower)
    /* all_upper = all_lower = true: Nothing to convert.
     all_upper = all_lower = false: "Mixed case represents itself." */
    return string;
  if (all_upper)
    /* all_upper = true, all_lower = false: STRING-DOWNCASE */
    return string_downcase(string);
  else
    /* all_upper = false, all_lower = true: STRING-UPCASE */
    return string_upcase(string);
}
/* the same, recursive like with SUBST: */
local object subst_common_case (object obj) {
  SUBST_RECURSE(common_case(obj),subst_common_case);
}

#ifdef LOGICAL_PATHNAMES

local bool legal_logical_word_char (chart ch) {
  ch = up_case(ch);
  var cint c = as_cint(ch);
  return (((c >= 'A') && (c <= 'Z'))
          || ((c >= '0') && (c <= '9'))
          || (c == '-'));
}

#endif

#if HAS_HOST

/* UP: Determines, if a character is allowed as character in the host-part
 of a namestring.
 legal_hostchar(ch)
 > chart ch: Character-Code
 < result: true if allowed, else false
 NB: legal_logical_word_char(ch) implies legal_hostchar(ch). */
local bool legal_hostchar (chart ch) {
 #if defined(PATHNAME_WIN32)
  { /* This is just a guess. I do not know which characters are allowed in
       Windows host names. */
    var cint c = as_cint(ch);
    return ((c >= ' ') && (c <= '~')
            && (c != '"') && (c != '/') && (c != ':')
            && (c != '<') && (c != '>') && (c != '\\'));
  }
 #else
  return alphanumericp(ch) || chareq(ch,ascii('-'));
 #endif
}

/* UP: check an optional HOST argument
 test_optional_host(host,convert)
 > host: Host-Argument
 > convert: Flag, if case-conversion is undesired
 < result: valid host-component
 can trigger GC */
local maygc object test_optional_host (object host, bool convert) {
  if (!boundp(host) || eq(host,S(Kunspecific)))
    return NIL;
  if (nullp(host))
    goto OK; /* NIL is OK */
  /* Else, host must be a String, whose characters are alphanumeric: */
  if (!stringp(host)) {
    pushSTACK(host);         /* TYPE-ERROR slot DATUM */
    pushSTACK(O(type_host)); /* TYPE-ERROR slot EXPECTED-TYPE */
    pushSTACK(host);
    pushSTACK(TheSubr(subr_self)->name);
    error(type_error,GETTEXT("~S: host should be NIL or a string, not ~S"));
  }
  host = coerce_normal_ss(host); /* as Normal-Simple-String */
  if (convert)
    host = common_case(host);
  {
    var uintL len = Sstring_length(host);
    if (len > 0) {
      var const chart* charptr = &TheSnstring(host)->data[0];
      dotimespL(len,len, {
        var chart ch = *charptr++;
        if (!legal_hostchar(ch))
          goto badhost;
      });
    }
  }
 OK: return host;
 badhost:
  pushSTACK(host);
  pushSTACK(TheSubr(subr_self)->name);
  error(parse_error,GETTEXT("~S: illegal hostname ~S"));
}

#else

#ifdef LOGICAL_PATHNAMES

/* UP: check an optional HOST argument
 test_optional_host(host)
 > host: Host-Argument
 < result: valid host-component
 can trigger GC */
local maygc object test_optional_host (object host) {
  if (!boundp(host) || eq(host,S(Kunspecific)))
    return NIL; /* not specified -> NIL */
  if (nullp(host))
    goto OK; /* NIL is OK */
  /* Else, host must be a String, whose characters are alphanumeric: */
  if (!stringp(host)) {
    pushSTACK(host);         /* TYPE-ERROR slot DATUM */
    pushSTACK(O(type_host)); /* TYPE-ERROR slot EXPECTED-TYPE */
    pushSTACK(host);
    pushSTACK(TheSubr(subr_self)->name);
    error(type_error,GETTEXT("~S: host should be NIL or a string, not ~S"));
  }
  host = coerce_normal_ss(host); /* as Normal-Simple-String */
  {
    var uintL len = Sstring_length(host);
    if (len > 0) {
      var object storage = host; sstring_un_realloc(storage);
      SstringDispatch(storage,X, {
        var const cintX* ptr = &((SstringX)TheVarobject(storage))->data[0];
        dotimespL(len,len, {
          var chart ch = as_chart(*ptr++);
          if (!legal_logical_word_char(ch))
            goto badhost;
        });
      });
    }
  }
 OK: return host;
 badhost:
  pushSTACK(host);
  pushSTACK(TheSubr(subr_self)->name);
  error(parse_error,GETTEXT("~S: illegal hostname ~S"));
}

#else

/* UP: check an optional HOST argument
 test_optional_host(host);
 > host: Host-Argument
 < result: valid host-component */
local object test_optional_host (object host) {
  if (boundp(host)       /* not specified -> OK */
      && !nullp(host)    /* specified -> should be NIL or :UNSPECIFIC */
      && !eq(host,S(Kunspecific))) {
    pushSTACK(host);     /* TYPE-ERROR slot DATUM */
    pushSTACK(S(null));  /* TYPE-ERROR slot EXPECTED-TYPE */
    pushSTACK(host);
    pushSTACK(TheSubr(subr_self)->name);
    error(type_error,GETTEXT("~S: host should be NIL, not ~S"));
  }
  return NIL;
}

#endif

#endif

/* Determines, if two characters count as equal characters in pathnames.
 equal_pathchar(ch1,ch2)
 > chart ch1,ch2: Character-Codes
 < result: true if equal, else false */
  #if !defined(PATHNAME_WIN32)
    #define equal_pathchar(ch1,ch2)  chareq(ch1,ch2)
  #else /* defined(PATHNAME_WIN32) */
    /* Case-insensitive, but normally without conversion */
    #define equal_pathchar(ch1,ch2)  chareq(up_case(ch1),up_case(ch2))
  #endif

/* UP: check whether a given byte is a valid element of NAME or TYPE
 component in a Namestring
 legal_namebyte(ch)
 > uintB: byte
 < return: true if valid, else false */
local inline bool legal_namebyte (uintB ch) {
  #ifdef VALID_FILENAME_CHAR    /* defined in config.h */
    return VALID_FILENAME_CHAR || (ch=='*') || (ch=='?');
  #else
    #ifdef PATHNAME_UNIX
      return ((ch>=' ') && (ch<='~') && !(ch=='/'));
    #endif
    #ifdef PATHNAME_WIN32
      return ((ch >= 1) && (ch <= 127)
              && (ch != '"') /*&& (ch != '*')*/
              && (ch != '/') && (ch != ':')
              && (ch != '<') && (ch != '>') /*&& (ch != '?')*/
              && (ch != '\\'))
             || (ch == 131)
             || (ch >= 160);
    #endif
  #endif
}

/* UP: check whether the character is a valid element of NAME or TYPE
 component in a Namestring
 legal_namechar(ch)
 > chart ch: character-code
 < return: true if valid, else false */
local bool legal_namechar (chart ch) {
  #ifdef UNICODE
    var uintB buf[4];   /* are there characters longer than 4 bytes?! */
    var uintL char_len = cslen(O(pathname_encoding),&ch,1);
    cstombs(O(pathname_encoding),&ch,1,buf,char_len);
    while (char_len > 0) {
      char_len--;
      if (!legal_namebyte(buf[char_len])) return false;
    }
    return true;
  #else
    return legal_namebyte(as_cint(ch));
  #endif
}

/* Determines, if a character is a wildcard for a single
 character.
 singlewild_char_p(ch)
 > chart ch: Character-Code
 < result: true if yes, else false */
#define singlewild_char_p(ch)  chareq(ch,ascii('?'))
#define multiwild_char_p(ch)  chareq(ch,ascii('*'))
#define wild_char_p(ch)   (multiwild_char_p(ch) || singlewild_char_p(ch))

/* Converts an object into a pathname. */
local object coerce_xpathname (object obj); /* later */

/* Converts an object into a non-logical pathname. */
local object coerce_pathname (object obj); /* later */
#if !defined(LOGICAL_PATHNAMES)
#define coerce_pathname(obj)  coerce_xpathname(obj)
#endif

/* Returns a default-pathname. */
local object defaults_pathname (void); /* later */

/* checks a default-pathname.
 test_default_pathname(defaults)
 > defaults: defaults-argument
 < result: value of the defaults-argument, a pathname
 can trigger GC */
local maygc object test_default_pathname (object defaults) {
  if (missingp(defaults))
    /* not specified -> take value of *DEFAULT-PATHNAME-DEFAULTS* : */
    return defaults_pathname();
  else
    /* specified -> turn into a pathname: */
    return coerce_xpathname(defaults);
}

/* <http://www.lisp.org/HyperSpec/Body/sec_19-2-3.html>:
 "for functions that manipulate or inquire about files in the file system,
  the pathname argument to such a function is merged with
  *DEFAULT-PATHNAME-DEFAULTS* before accessing the file system"
 When pathname comes from a file stream, this is NOT done because
 that pathname has already been "transfered from the world of the abstract
 Lisp pathname algebra to the real world of computer file system"
 Another option is to ensure that all slots of *DEFAULT-PATHNAME-DEFAULTS*
 are non-NIL (use :UNSPECIFIC instead): then merge_defaults() becomes
 an idempotent operation -- assuming trivial directory or non-ANSI merging.

 merge_defaults(pathname)
 > pathname: a pathname
 < result: a pathname derived from it, with *DEFAULT-PATHNAME-DEFAULTS* merged
           in.
 can trigger GC */
local maygc object merge_defaults (object pathname) {
  pushSTACK(pathname); pushSTACK(defaults_pathname());
  funcall(L(merge_pathnames),2);
  return value1;
}

/* error-message because of illegal pathname-argument.
 error_pathname_designator(thing); ( error_... )
 > thing: (erroneous) argument */
nonreturning_function(local, error_pathname_designator, (object thing)) {
  pushSTACK(thing);                       /* TYPE-ERROR slot DATUM */
  pushSTACK(O(type_designator_pathname)); /* TYPE-ERROR slot EXPECTED-TYPE */
  pushSTACK(O(type_designator_pathname));
  pushSTACK(thing);
  pushSTACK(TheSubr(subr_self)->name);
  error(type_error,
         GETTEXT("~S: argument ~S should be a pathname designator ~S"));
}

/* Tracks a chain of Synonym-Streams, so long as a File-Stream
 is reached.
 as_file_stream(stream)
 > stream: Builtin-Stream
 < stream: File-Stream */
local object as_file_stream (object stream) {
  var object s = stream;
  while (1) {
    if (TheStream(s)->strmtype == strmtype_file)
      return s;
    if (!(TheStream(s)->strmtype == strmtype_synonym))
      break;
    s = Symbol_value(TheStream(stream)->strm_synonym_symbol);
    if (!builtin_stream_p(s))
      break;
  }
  error_pathname_designator(stream);
}

/* Signal an error if a file-stream does not have
 a file-name associated with it.
 test_file_stream_named(stream)
 > stream: File-Stream */
#define test_file_stream_named(stream)  \
  do { if (nullp(TheStream(stream)->strm_file_truename)) \
         error_file_stream_unnamed(stream);             \
  } while(0)
nonreturning_function(local, error_file_stream_unnamed, (object stream)) {
  pushSTACK(stream); /* FILE-ERROR slot PATHNAME */
  pushSTACK(stream);
  pushSTACK(TheSubr(subr_self)->name);
  error(file_error,GETTEXT("~S: filename for ~S is unknown"));
}

#if defined(UNIX) || defined(WIN32_NATIVE)

#ifdef UNIX
  #define slash  '/'
#endif
#ifdef WIN32_NATIVE
  #define slash  '\\'
#endif
/* physical slash */
#ifdef PATHNAME_WIN32
 #define pslashp(c)  (chareq(c,ascii('\\')) || chareq(c,ascii('/')))
 #define cpslashp(c) ((c) == '\\' || (c) == '/')
#else /* PATHNAME_UNIX */
 #define pslashp(c)  chareq(c,ascii(slash))
 #define cpslashp(c) ((c) == slash)
#endif
#define colonp(c)    chareq(c,ascii(':'))
#ifndef LOGICAL_PATHNAMES
#define lslashp(c)   pslashp(c)
#endif
#define dotp(c)      chareq(c,ascii('.'))
#define starp(c)     chareq(c,ascii('*'))

/* UP: add a character to an ASCII string and return as a Lisp string
 can trigger GC */
#ifdef UNICODE
local /*maygc*/ object asciz_add_char (const char* chars, uintL len, char ch,
                                       object encoding)
#else
#define asciz_add_char(chars,len,ch,encoding)  asciz_add_char_(chars,len,ch)
local /*maygc*/ object asciz_add_char_ (const char* chars, uintL len, char ch)
#endif
{
  #ifdef UNICODE
  GCTRIGGER1(encoding);
  #else
  GCTRIGGER();
  #endif
  var DYNAMIC_ARRAY(buf,char,len+1);
  begin_system_call(); memcpy(buf,chars,len); end_system_call();
  buf[len] = ch;
  var object s = n_char_to_string(buf,len+1,encoding);
  FREE_DYNAMIC_ARRAY(buf);
  return s;
}

/* UP: Converts a Unix-Directory-Specification into a pathname.
 asciz_dir_to_pathname(path,encoding)
 > const char* path: path as ASCIZ-String
 > encoding: Encoding
 < result: as a pathname without name and type
 can trigger GC */
#ifdef UNICODE
local /*maygc*/ object asciz_dir_to_pathname(const char* path, object encoding)
#else
#define asciz_dir_to_pathname(path,encoding)  asciz_dir_to_pathname_(path)
local /*maygc*/ object asciz_dir_to_pathname_(const char* path)
#endif
{
  #ifdef UNICODE
  GCTRIGGER1(encoding);
  #else
  GCTRIGGER();
  #endif
  var object pathname;
  var uintL len = asciz_length(path); /* string length */
  /* if the String does not end with a '/' already, a '/' is added: */
  if ((len>0) && cpslashp(path[len-1]))
    pathname = n_char_to_string(path,len,encoding);
  else
    pathname = asciz_add_char(path,len,slash,encoding);
  /* and convert into a pathname: */
  return coerce_pathname(pathname);
}

#endif

/* Type for PARSE-NAMESTRING:
 State while the string is being parsed character by character. */
typedef struct {
  uintL index;    /* index (incl. offset) */
  object FNindex; /* index as a fixnum */
  uintL count;    /* number of the remaining characters */
} zustand;        /* "state" */

/* Skip s characters. */
#define Z_SHIFT(z,s) \
 do { (z).index += (s); (z).FNindex = fixnum_inc((z).FNindex,(s)); (z).count -= (s); } while(0)

/* Tests whether the current character at Z satisfies pred. */
#define Z_AT_SLASH(z,pred,st) \
  (((z).count != 0) && pred(schar(st,(z).index)))

/* Replace this string with a substring. */
#define Z_SUB(z,s) ((s) = subsstring((s),(z).index,(z).index+(z).count), (z).index = 0)

#ifdef LOGICAL_PATHNAMES

/* Parsing of logical pathnames. */

/* separator between subdirs */
#define semicolonp(c)  (chareq(c,ascii(';')))
#define lslashp(c)     semicolonp(c)

/* Copy LEN characters in string ORIG starting at ORIG_OFFSET to string DEST,
   starting at DEST_OFFSET, up-casing all characters. LEN is > 0. */
local void copy_upcase (object dest, uintL dest_offset,
                        object orig, uintL orig_offset, uintL len) {
  sstring_un_realloc(orig);
  SstringDispatch(orig,X1, {
    var cintX1* ptr1 = &((SstringX1)TheVarobject(orig))->data[orig_offset];
    sstring_un_realloc(dest);
    SstringDispatch(dest,X2, {
      var cintX2* ptr2 = &((SstringX2)TheVarobject(dest))->data[dest_offset];
      dotimespL(len,len, { *ptr2++ = as_cint(up_case(as_chart(*ptr1++))); });
    });
  });
}

/* Parses the name/type/version part (if subdirp=false) or a subdir part
 (if subdirp=true) of a logical pathname.
 parse_logical_word(&z,subdirp)
 > STACK_2: storage vector, a normal-simple-string
 > zustand z: start state
 < zustand z: updated
 < result: a normal-simple-string or :WILD or :WILD-INFERIORS or NIL
 can trigger GC */
local maygc object parse_logical_word (zustand* z, bool subdirp) {
  ASSERT(sstring_normal_p(STACK_2));
  var zustand startz = *z; /* start-state */
  var chart ch;
  /* Is there a sequence of alphanumeric characters or '*',
   no two '*' adjacent (except "**", if subdirp),
   and, if subdirp, a ';' ? */
  var bool last_was_star = false;
  var bool seen_starstar = false;
  while (z->count) {
    ch = schar(STACK_2,z->index); /* next character */
    if (!legal_logical_word_char(ch)) {
      if (starp(ch)) {
        if (last_was_star) {
          if (subdirp && (z->index - startz.index == 1))
            seen_starstar = true;
          else
            break; /* adjacent '*' are forbidden */
        } else
          last_was_star = true;
      } else
        break;
    }
    /* skip character: */
    Z_SHIFT(*z,1);
  }
  var uintL len = z->index - startz.index;
  if (subdirp) {
    if ((z->count == 0) || !lslashp(ch)) {
      *z = startz; return NIL; /* no ';' -> no subdir */
    }
    /* skip character ';' : */
    Z_SHIFT(*z,1);
  }
  if (len==0)
    return NIL;
  else if ((len==1) && starp(schar(STACK_2,startz.index)))
    return S(Kwild);
  else if ((len==2) && seen_starstar)
    return S(Kwild_inferiors);
  else {
    var object result = allocate_string(len);
    copy_upcase(result,0,STACK_2,startz.index,len);
    return result;
  }
}

/* Test whether a string is a digit sequence.
 all_digits(string)
 > string: a normal-simple-string
 < true if the string consists entirely of digits, else false */
local bool all_digits (object string) {
  var uintL len = Sstring_length(string);
  if (len > 0) {
    var object storage = string; sstring_un_realloc(storage);
    SstringDispatch(storage,X, {
      var const cintX* ptr = &((SstringX)TheVarobject(storage))->data[0];
      dotimespL(len,len, {
        var cintX c = *ptr++;
        if (!((c >= '0') && (c <= '9')))
          return false;
      });
    });
  }
  return true;
}

/* test whether the string contains semicolons (and the rest being valid!),
 thus appearing to be a logical pathname
 > string: storage vector, a normal-simple-string
 < result: true if the string contains semicolons */
local bool looks_logical_p (object string) {
  var uintL len = Sstring_length(string);
  var bool logical_p = false;
  if (len > 0) {
    SstringDispatch(string,X, {
      var const cintX* charptr = &((SstringX)TheVarobject(string))->data[0];
      do {
        var chart ch = up_case(as_chart(*charptr++));
        if (!legal_logical_word_char(ch)) {
          if (semicolonp(ch))
            logical_p = true;
          else if (!colonp(ch) && !dotp(ch) && !starp(ch))
            return false; /* invalid logical pathname char */
        }
      } while (--len);
    });
  }
  return logical_p;
}

/* Attempt to parse a logical host name string, starting at a given state.
 parse_logical_host_prefix(&z,string)
 > string: storage vector, a normal-simple-string
 > state z: start state
 < state z: updated to point past the colon after the logical host
 < result: logical host, or NIL
 can trigger GC */
local maygc object parse_logical_host_prefix (zustand* zp, object string) {
  ASSERT(sstring_normal_p(string));
  var object host;
  var uintL startindex = zp->index;
  var chart ch;
  /* a sequence of alphanumeric characters and then ':' */
  while (1) {
    if (zp->count==0)
      return NIL; /* string already ended -> no host */
    ch = schar(string,zp->index); /* next character */
    if (!legal_logical_word_char(ch))
      break;
    /* go past alphanumeric character: */
    Z_SHIFT(*zp,1);
  }
  if (!colonp(ch))
    return NIL; /* no ':' -> no host */
  { /* make host-string: */
    var uintL len = zp->index - startindex;
    pushSTACK(string);
    host = allocate_string(len);
    string = popSTACK();
    /* and fill it: */
    if (len > 0)
      copy_upcase(host,0,string,startindex,len);
  }
  /* skip ':' */
  Z_SHIFT(*zp,1);
  return host;
}

/* CLHS for MAKE-PATHNAME: "Whenever a pathname is constructed the
 components may be canonicalized if appropriate."
 simplify the subdirectory list
 strings are coerced to normal simple strings
 the list should start with a valid startpoint (not checked!)
 > dir : pathname directory list
 < dir : the same list, destructively modified:
         ".." or :back         ==> :up
         ... x "foo" :up y ... ==> ... x y ...
         ... x  ""/"."   y ... ==> ... x y ...
         :absolute :up         ==> error
         :wild-inferiors :up   ==> error
 can trigger GC */
local maygc object simplify_directory (object dir) {
  if (!consp(dir)) return dir;
  DOUT("simplify_directory:< ",dir);
  pushSTACK(dir);
  { /* kill ".", ".."->:up, coerce to normal simple strings */
    var object curr = dir;
    while (consp(curr) && consp(Cdr(curr))) {
      var object next = Cdr(curr);
      var object here = Car(next);
      if (stringp(here)) {
        if (vector_length(here)==0 || string_equal(here,O(dot_string))) {
          Cdr(curr) = Cdr(next); /* drop "." and "" */
          continue;
        } else if (string_equal(here,O(wild_string))) {
          Car(next) = S(Kwild);
          curr = next;
          continue;
        } else if (string_equal(here,O(wildwild_string))) {
          Car(next) = S(Kwild_inferiors);
          curr = next;
          continue;
        } else if (!consp(next))
          break;
        if (string_equal(here,O(dotdot_string)))
          Car(next) = S(Kup); /* ".." --> :UP */
        else { /* coerce to normal */
          pushSTACK(next);
          var object element = coerce_normal_ss(here);
          next = popSTACK();
          Car(next) = element;
        }
      } else if (eq(here,S(Kback)))
        Car(next) = S(Kup); /* :BACK --> :UP (ANSI) */
      curr = next;
    }
  }
  dir = popSTACK();
  /* collapse "foo/../" (quadratic algorithm) */
  var bool changed_p;
  do {
    changed_p = false;
    var object curr = dir;
    while (consp(curr) && consp(Cdr(curr))) {
      var object next = Cdr(curr);
      var object here = Car(next);
      var object next_next = Cdr(next);
      if (consp(next_next)) {
        var object next_here = Car(next_next);
        /* :BACK has been converted to :UP */
        if (!eq(here,S(Kup)) && eq(next_here,S(Kup))) {
          if (eq(here,S(Kwild_inferiors)) || eq(here,S(Kabsolute))) {
            goto error_absolute_up;
          } else {
            Cdr(curr) = Cdr(next_next); /* collapse ( "foo" :UP ) */
            changed_p = true;
          }
        } else
          curr = next;
      } else
        curr = next;
    }
  } while (changed_p);
  if (eq(Car(dir),S(Kabsolute)) && consp(Cdr(dir)))
    if (eq(Car(Cdr(dir)),S(Kup)))
      goto error_absolute_up;
  DOUT("simplify_directory:> ",dir);
  return dir;
 error_absolute_up:
  /* <http://www.lisp.org/HyperSpec/Body/sec_19-2-2-4-3.html> */
  pushSTACK(O(empty_string)); /* FILE-ERROR slot PATHNAME */
  pushSTACK(dir); pushSTACK(S(Kdirectory));
  pushSTACK(TheSubr(subr_self)->name);
  error(file_error,GETTEXT("~S: illegal ~S argument ~S"));
}

/* Parses a logical pathname.
 parse_logical_pathnamestring(z)
 > STACK_1: storage vector, a normal-simple-string
 > STACK_0: freshly allocated logical pathname
 > state z: start state
 < STACK_0: same logical pathname, filled
 < result: number of remaining characters
 can trigger GC */
local maygc uintL parse_logical_pathnamestring (zustand z) {
  DOUT("parse_logical_pathnamestring:<0",STACK_0);
  DOUT("parse_logical_pathnamestring:<1",STACK_1);
  { /* parse Host-Specification: */
    var zustand startz = z;
    var object host = parse_logical_host_prefix(&z,STACK_1);
    if (nullp(host)) {
      z = startz; /* back to the start */
      host = STACK_(3+2); /* Default-Host */
    } else { /* enter host: */
      TheLogpathname(STACK_0)->pathname_host = host;
    }
  }
  { /* enter Directory-Start: */
    var object new_cons = allocate_cons(); /* new Cons for Startpoint */
    TheLogpathname(STACK_0)->pathname_directory = new_cons;
    pushSTACK(new_cons); /* new (last (pathname-directory Pathname)) */
  }
  /* stack layout:
   data-vector, pathname, (last (pathname-directory Pathname)).
   parse subdirectories:
   If ";" is the first char, it is turned into :RELATIVE
   (otherwise :ABSOLUTE) as the first subdir
   for a reason that escapes me, ANSI CL specifies that
   "foo:;bar;baz.zot" is a  :RELATIVE logical pathname while
   "foo:/bar/baz.zot" is an :ABSOLUTE physical pathname.
   see "19.3.1.1.3 The Directory part of a Logical Pathname Namestring"
   http://www.lisp.org/HyperSpec/Body/sec_19-3-1-1-3.html */
  if (Z_AT_SLASH(z,lslashp,STACK_2)) {
    Z_SHIFT(z,1);
    Car(STACK_0) = S(Krelative);
  } else {
    Car(STACK_0) = S(Kabsolute);
  }
  while (1) {
    /* try to parse the next subdir */
    var object subdir = parse_logical_word(&z,true);
    if (nullp(subdir))
      break;
    /* lengthen (pathname-directory pathname) by Subdir: */
    pushSTACK(subdir);
    var object new_cons = allocate_cons(); /* new Cons */
    Car(new_cons) = popSTACK(); /* = (cons subdir NIL) */
    Cdr(STACK_0) = new_cons; /* lengthens (pathname-directory Pathname) */
    STACK_0 = new_cons; /* new (last (pathname-directory Pathname)) */
  }
  { /* parse Name: */
    var object name = parse_logical_word(&z,false);
    TheLogpathname(STACK_1)->pathname_name = name;
    if ((z.count > 0) && dotp(schar(STACK_2,z.index))) {
      var zustand z_name = z;
      /* skip Character '.' : */
      Z_SHIFT(z,1);
      /* parse Type: */
      var object type = parse_logical_word(&z,false);
      TheLogpathname(STACK_1)->pathname_type = type;
      if (!nullp(type)) {
        if ((z.count > 0) && dotp(schar(STACK_2,z.index))) {
          var zustand z_type = z;
          /* skip Character '.' : */
          Z_SHIFT(z,1);
          /* parse Version: */
          var object version = parse_logical_word(&z,false);
          if (eq(version,S(Kwild))) {
          } else if (equal(version,Symbol_name(S(Knewest)))) {
            version = S(Knewest);
          } else if (stringp(version) && all_digits(version)) {
            pushSTACK(version); funcall(L(parse_integer),1);
            version = value1; /* version: string -> integer */
          } else {
            version = NIL;
          }
          TheLogpathname(STACK_1)->pathname_version = version;
          if (nullp(version))
            z = z_type; /* restore character '.' */
        } else {
          TheLogpathname(STACK_1)->pathname_version = NIL;
        }
      } else {
        z = z_name; /* restore character '.' */
        TheLogpathname(STACK_1)->pathname_version = NIL;
      }
    } else {
      TheLogpathname(STACK_1)->pathname_type = NIL;
      TheLogpathname(STACK_1)->pathname_version = NIL;
    }
  }
  skipSTACK(1);
  TheLogpathname(STACK_0)->pathname_directory =
    simplify_directory(TheLogpathname(STACK_0)->pathname_directory);
  DOUT("parse_logical_pathnamestring:>0",STACK_0);
  DOUT("parse_logical_pathnamestring:>1",STACK_1);
  return z.count;
}

/* recognition of a logical host, cf. CLtL2 p. 631
 (defun logical-host-p (host)
   (and (simple-string-p host)
        (gethash host sys::*logical-pathname-translations*) ; :test #'equalp !
        t)) */
local bool logical_host_p (object host) {
  return (simple_string_p(host)
          /* No need to string-upcase host, because it's tested via EQUALP. */
          && !eq(gethash(host,Symbol_value(S(logpathname_translations)),false),
                 nullobj));
}

#endif

#define string2wild(str)  (equal(str,O(wild_string)) ? S(Kwild) : (object)(str))
#define wild2string(obj)  (eq(obj,S(Kwild)) ? (object)O(wild_string) : (obj))

#ifdef PATHNAME_NOEXT
/* can trigger GC */
local maygc void fix_parse_namestring_dot_file (void)
{ /* make sure *PARSE-NAMESTRING-DOT-FILE* is valid */
  Symbol_value(S(parse_namestring_dot_file)) = S(Ktype); /*CLISP default*/
  pushSTACK(NIL);
  pushSTACK(S(parse_namestring_dot_file));
  pushSTACK(S(parse_namestring_dot_file));
  pushSTACK(Symbol_value(S(parse_namestring_dot_file)));
  STA…