/* -*- mode: c -*- */
/*
    pathname.d -- Pathnames.
*/
/*
    Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
    Copyright (c) 1990, Giuseppe Attardi.
    Copyright (c) 2001, Juan Jose Garcia Ripoll.

    Copyright (c) 2010-2014, Jean-Claude Beaudoin

    MKCL is free software; you can redistribute it and/or
    modify it under the terms of the GNU Lesser General Public
    License as published by the Free Software Foundation; either
    version 3 of the License, or (at your option) any later version.

    See file '../../Copyright' for full details.
*/

/*
	This file contains those functions that interpret namestrings.
*/

#include <mkcl/mkcl.h>
#include <mkcl/mkcl-inl.h>
#include <mkcl/internal.h>
#include <string.h>
#include <ctype.h>

static void
push_substring(MKCL, mkcl_object buffer, mkcl_object string, mkcl_index start, mkcl_index end)
{
  string = mk_cl_string(env, string);
  while (start < end) {
    mkcl_string_push_extend(env, buffer, mkcl_char(env, string, start));
    start++;
  }
}

static void
push_string(MKCL, mkcl_object buffer, mkcl_object string)
{
  push_substring(env, buffer, string, 0, mkcl_length(env, string));
}

static mkcl_object
canonicalize_directory_destructively(MKCL, mkcl_object directory, bool logical)
{
  /* This function performs the following tasks:
   * 1) It ensures that the list is a well formed directory list.
   * 2) It ensures on non-logical pathnames that all "." strings in the list are removed.
   * 3) It ensures on non-logical pathnames that all ".." strings in the list are replaced by their corresponding keyword.
   */
  /* INV: directory is always a list */
  mkcl_object ptr;
  int i;

  if (mkcl_Null(directory) || directory == @':unspecific')
    return directory;
  if (!MKCL_LISTP(directory))
    return @':error';
  if (MKCL_CONS_CAR(directory) != @':absolute' &&
      MKCL_CONS_CAR(directory) != @':relative')
    return @':error';
 BEGIN:
  for (i=0, ptr=directory; MKCL_CONSP(ptr); ptr = MKCL_CONS_CDR(ptr), i++) {
    mkcl_object item = MKCL_CONS_CAR(ptr);
    if (item == @':back') {
      if (i == 0)
	return @':error';
      item = mkcl_nth(env, i-1, directory);
      if (item == @':absolute' || item == @':wild-inferiors')
	return @':error';
      if (i >= 2)
	MKCL_RPLACD(mkcl_nthcdr(env, i-2, directory), MKCL_CONS_CDR(ptr));
    } else if (item == @':up') {
      if (i == 0)
	return @':error';
      item = mkcl_nth(env, i-1, directory);
      if (item == @':absolute' || item == @':wild-inferiors')
	return @':error';
    } else if (item == @':relative' || item == @':absolute') {
      if (i > 0)
	return @':error';
    } else if (mkcl_stringp(env, item)) {
      mkcl_word l = mkcl_string_length(env, item);
      if (logical)

        {
          MKCL_RPLACA(ptr, mk_cl_string_upcase(env, 1, item)); /* logical pathnames are uppercase only. */
          continue; /* In logical pathnames, "." and ".." have no special meaning and are valid directory names. */
        }

      if (l && mkcl_char(env, item, 0) == '.') {
	if (l == 1) {
	  /* Single dot */
	  if (i == 0)
	    return @':error';
	  MKCL_RPLACD(mkcl_nthcdr(env, i-1, directory), MKCL_CONS_CDR(ptr));
	  goto BEGIN;
	} else if (l == 2 && mkcl_char(env, item,1) == '.') {
	  MKCL_RPLACA(ptr, @':back'); /* Why :back and not rather :up here? JCB */
	  goto BEGIN;
	}
      }
    } else if (item != @':wild' && item != @':wild-inferiors') {
      return @':error';
    }
  }
  return directory;
}

static mkcl_object _make_pathname(MKCL, bool logical, mkcl_object host, mkcl_object device, mkcl_object directory,
				  mkcl_object name, mkcl_object type, mkcl_object version)
{
  mkcl_object p = mkcl_alloc_raw_pathname(env);

  p->pathname.logical   = logical;
  p->pathname.complete  = FALSE;
  p->pathname.host      = host;
  p->pathname.device    = device;
  p->pathname.directory = directory;
  p->pathname.name      = name;
  p->pathname.type      = type;
  p->pathname.version   = version;
  p->pathname.namestring = mk_cl_Cnil;
  return p;
}

mkcl_object
mkcl_make_pathname(MKCL, mkcl_object host, mkcl_object device, mkcl_object directory,
		   mkcl_object name, mkcl_object type, mkcl_object version)
{
  mkcl_object bad_value = mk_cl_Cnil, bad_component = mk_cl_Cnil;
  bool logical = FALSE;
  bool a_component_is_nil = FALSE;

  if (mkcl_stringp(env, host))
    logical = mkcl_logical_hostname_p(env, host);
  else if (host == mk_cl_Cnil)
    {
      logical = FALSE;
      a_component_is_nil = TRUE;
    }
  else
    {
      bad_value = host;
      bad_component = @':host';
      goto _MKCL_ERROR;
    }

  if (device == MKCL_OBJNULL)
    device = (logical ? @':unspecific' : mk_cl_Cnil);

  if (logical)
    device = @':unspecific';
  else if (mkcl_Null(device))
    a_component_is_nil = TRUE;
  else if (!(mkcl_stringp(env, device) || (device == @':unspecific') || (device == @':wild')))
    {
      bad_value = device;
      bad_component = @':device';
      goto _MKCL_ERROR;
    }

  if (mkcl_Null(name))
    a_component_is_nil = TRUE;
  else if ((logical && name == @':unspecific')
	   || (!mkcl_stringp(env, name) && name != @':wild' && name != @':unspecific' )) {
    bad_value = name;
    bad_component = @':name';
    goto _MKCL_ERROR;
  }

  if (logical && mkcl_stringp(env, name)) name = mk_cl_string_upcase(env, 1, name);

  if (mkcl_Null(type))
    a_component_is_nil = TRUE;
  else if ((logical && type == @':unspecific')
	   || (!mkcl_stringp(env, type) && type != @':wild' && type != @':unspecific')) {
    bad_value = type;
    bad_component = @':type';
    goto _MKCL_ERROR;
  }

  if (logical && mkcl_stringp(env, type)) type = mk_cl_string_upcase(env, 1, type);

  if (mkcl_Null(version))
    a_component_is_nil = TRUE;
  else if ((logical && version == @':unspecific')
	   || (version != @':newest' && version != @':unspecific' && version != @':wild'
	       && !(MKCL_FIXNUMP(version) && mkcl_plusp(env, version))))
    {
      bad_value = version;
      bad_component = @':version';
      goto _MKCL_ERROR;
    }

  switch (mkcl_type_of(directory)) {
  case mkcl_t_string:
  case mkcl_t_base_string:
    directory = mkcl_cons(env, @':absolute', mkcl_list1(env, directory));
    break;
  case mkcl_t_symbol:
    if (mkcl_Null(directory)) {
      a_component_is_nil = TRUE;
      break;
    }
    if (!logical && directory == @':unspecific')
      break;
    if (directory == @':wild') {
      directory = mkcl_cons(env, @':absolute', mkcl_list1(env, @':wild-inferiors'));
      break;
    }
    bad_value = directory;
    bad_component = @':directory';
    goto _MKCL_ERROR;
  case mkcl_t_cons:
    /* validity of list content checked during canonicalization just here after. */

    /* Since we may destructively canonicalize the directory list, we copy it first. JCB */
    directory = mk_cl_copy_list(env, directory);

    break;
  case mkcl_t_null:
    a_component_is_nil = TRUE;
    break;
  default:
    bad_value = directory;
    bad_component = @':directory';
    goto _MKCL_ERROR;
  }

  {
    mkcl_object p = _make_pathname(env, logical, host, device, directory, name, type, version);
    p->pathname.logical = logical;
    if (canonicalize_directory_destructively(env, directory, logical) == @':error') {
      mk_cl_error(env, 3, @'file-error', @':pathname', p);
    }

    if (a_component_is_nil)
      p->pathname.complete = FALSE;
    else if (MKCL_CONSP(p->pathname.directory))
      p->pathname.complete = (MKCL_CONS_CAR(p->pathname.directory) == @':absolute');
    else
      p->pathname.complete = TRUE;
    return(p);
  }
 _MKCL_ERROR:
  if (logical)
    mkcl_FEerror(env, "~s is not a valid logical pathname pathname-~a component, logical host = ~S",
		 3, bad_value, bad_component, host);
  else
    mkcl_FEerror(env, "~s is not a valid pathname-~a component", 2, bad_value, bad_component);
  return(mk_cl_Cnil);
}

static mkcl_object
tilde_expand(MKCL, mkcl_object pathname)
{
  /*
   * If the pathname is a physical one, without hostname, without device
   * and the first element is either a tilde '~' or '~' followed by
   * a user name, we merge the user homedir pathname with this one.
   */
  mkcl_object directory, head;
  if (pathname->pathname.logical 
      || ((pathname->pathname.host != mk_cl_Cnil) && !mkcl_string_E(env, pathname->pathname.host, mkcl_core.localhost_string))
      || ((pathname->pathname.device != mk_cl_Cnil) && (pathname->pathname.device != @':unspecific'))
      )
    return pathname;

  directory = pathname->pathname.directory;
  if (!MKCL_CONSP(directory) 
      || MKCL_CONS_CAR(directory) != @':relative'
      || MKCL_CONS_CDR(directory) == mk_cl_Cnil) {
    return pathname;
  }
  head = MKCL_CADR(directory);
  if (mkcl_stringp(env, head)
      && mkcl_length(env, head) > 0
      && mkcl_char(env, head, 0) == '~') {
    mkcl_object homedir = mkcl_homedir_pathname(env, head);
    if (!mkcl_Null(homedir))
      {	/* Remove the tilde component */
	MKCL_RPLACD(directory, MKCL_CDDR(directory));
	pathname = mkcl_merge_pathnames(env, pathname, homedir, @':newest');
      }
  }
  return pathname;
}

static mkcl_object
make_one(MKCL, mkcl_object s, mkcl_index start, mkcl_index end)
{
  return mk_cl_subseq(env, 3, s, MKCL_MAKE_FIXNUM(start), MKCL_MAKE_FIXNUM(end));
}

/*
 * Translates a string into the host's preferred case.
 * See CLHS 19.2.2.1.2.2 Common Case in Pathname Components.
 */

static mkcl_object

common_transcase(MKCL, mkcl_object str)

{

  if (!MKCL_STRINGP(str)) {

    /* Pathnames may contain some other objects, such as symbols,
     * numbers, etc, which need not be translated */
    return str;
  }

  else { /* We use UN*X conventions, so lower case is the customary case. */
    enum mkcl_string_case string_case = mkcl_string_case(str);

    if (string_case == mkcl_uppercase_string) 
      return mk_cl_string_downcase(env, 1, str);
    else if (string_case == mkcl_lowercase_string)
      return mk_cl_string_upcase(env, 1, str); /* opposite customary case */
    else
      return str; /* Mixed case goes unchanged */

  }
}

static mkcl_object

common_transcase_list(MKCL, mkcl_object list)

{
  /* If the argument is really a list, translate all strings in it and
   * return this new list, else assume it is a string and translate it.
   */
  if (!MKCL_CONSP(list)) {

    return common_transcase(env, list);

  } else {

    mkcl_object l = list = mk_cl_copy_list(env, list);

    for (; MKCL_CONSP(l); l = MKCL_CONS_CDR(l)) {
      /* It is safe to pass anything to common_transcase,

       * because it will only transform strings, leaving other
       * object (such as symbols) unchanged.*/
      mkcl_object name = MKCL_CONS_CAR(l);

      name = common_transcase(env, name);

      MKCL_RPLACA(l, name);
    }
    return list;
  }
}


#define WORD_INCLUDE_DELIM 1
#define WORD_ALLOW_ASTERISK  2
#define WORD_EMPTY_IS_NIL 4
#define WORD_LOGICAL 8
#define WORD_SEARCH_LAST_DOT 16
#define WORD_ALLOW_LEADING_DOT 32
#define WORD_DISALLOW_SLASH 64
#define WORD_DISALLOW_SEMICOLON 128

typedef bool (*delim_fn)(mkcl_character);
static bool is_colon(mkcl_character c) { return c == ':'; }
static bool is_slash(mkcl_character c) { return MKCL_IS_DIR_SEPARATOR(c); }
static bool is_semicolon(mkcl_character c) { return c == ';'; }
static bool is_dot(mkcl_character c) { return c == '.'; }
static bool is_null(mkcl_character c) { return c == '\0'; }


/*
 * Parses a word from string `S' until either:
 *	1) character `DELIM' is found
 *	2) end of string is reached
 *	3) a non valid character is found
 * Output is either
 *	1) :error in case (3) above
 *	2) :wild, :wild-inferiors, :up
 *	3) "" or mk_cl_Cnil when word has no elements
 *	5) A non empty string
 */
static mkcl_object

parse_word(MKCL, mkcl_object s, delim_fn delim, int flags,
           mkcl_index start, mkcl_index end, mkcl_index *end_of_word,
           enum mkcl_namestring_specificity specificity)

{
  mkcl_index i, j, last_delim = end;
  bool wild_inferiors = FALSE;

  i = j = start;
  for (; i < end; i++) {
    bool valid_char;
    mkcl_character c = mkcl_char(env, s, i);
    if (delim(c)) {
      if ((i == start) && (flags & WORD_ALLOW_LEADING_DOT)) {
	/* Leading dot is included */
	continue;
      }
      last_delim = i;
      if (!(flags & WORD_SEARCH_LAST_DOT)) {
	break;
      }
    }
    if (c == '*') {

      if (!(flags & WORD_ALLOW_ASTERISK) && (specificity == mkcl_may_be_wild_namestring))

	valid_char = FALSE; /* Asterisks not allowed in this word */
      else {
	wild_inferiors = (i > start && mkcl_char(env, s, i-1) == '*');
	valid_char = TRUE; /* single "*" */
      }

    } else if (is_semicolon(c) && (flags & (WORD_DISALLOW_SEMICOLON | WORD_LOGICAL))) {

      valid_char = FALSE;

    } else if (is_slash(c) && (flags & (WORD_DISALLOW_SLASH | WORD_LOGICAL))) {

      valid_char = FALSE;
    } else {

      if (flags & WORD_LOGICAL)
	{

          if (c == '-')
            valid_char = TRUE;
	  else if (mkcl_alphanumericp(c))

	    valid_char = TRUE;
	  else
	    valid_char = FALSE;
	}
      else
	valid_char = c != 0; /* What is wrong with character code 0? JCB */

    }
    if (!valid_char) {
      *end_of_word = start;
      return @':error';
    }
  }
  if (i > last_delim) {
    /* Go back to the position of the last delimiter */
    i = last_delim;
  }
  if (i < end) {
    *end_of_word = i+1;
  } else {
    *end_of_word = end;
    /* We have reached the end of the string without finding
       the proper delimiter */
    if (flags & WORD_INCLUDE_DELIM) {
      *end_of_word = start;
      return mk_cl_Cnil;
    }
  }

  switch(i-j)
    {
    case 0:
      if (flags & WORD_EMPTY_IS_NIL)
        return mk_cl_Cnil;
      return mkcl_core.empty_string;
    case 1:

      if ((mkcl_char(env, s,j) == '*') && (specificity == mkcl_may_be_wild_namestring))

        return @':wild';
      break;
    case 2:
      {
        mkcl_character c0 = mkcl_char(env, s,j);
        mkcl_character c1 = mkcl_char(env, s,j+1);

        if ((c0 == '*' && c1 == '*') && (specificity == mkcl_may_be_wild_namestring))

          return @':wild-inferiors';
        if (!(flags & (WORD_LOGICAL | WORD_ALLOW_LEADING_DOT)) && c0 == '.' && c1 == '.')
          return @':up';
      }

      break;

    default:

      if (wild_inferiors && (specificity == mkcl_may_be_wild_namestring)) /* '**' surrounded by other characters */

        return @':error';
    }
  {
    mkcl_object word = make_one(env, s, j, i);

    if (flags & WORD_LOGICAL)
      return mk_cl_nstring_upcase(env, 1, word);
    else
      return word;
  }

}

/*
 * Parses a logical or physical directory tree. Output is always a
 * list of valid directory components, which may be just NIL.
 *
 * INV: When parsing of directory components has failed, a valid list
 * is also returned, and it will be later in the parsing of
 * pathname-name or pathname-type when the same error is detected.
 */

static mkcl_object

parse_directories(MKCL, mkcl_object s, int flags,
                  mkcl_index start, mkcl_index end, mkcl_index *end_of_dir,
                  enum mkcl_namestring_specificity specificity)

{
  mkcl_index i, j;
  mkcl_object path = mk_cl_Cnil;
  delim_fn delim = (flags & WORD_LOGICAL) ? is_semicolon : is_slash;

  flags |= WORD_INCLUDE_DELIM | WORD_ALLOW_ASTERISK;
  *end_of_dir = start;
  for (i = j = start; i < end; j = i) {

    mkcl_object part = parse_word(env, s, delim, flags, j, end, &i, specificity);

    if (part == @':error' || part == mk_cl_Cnil)
      break;
    if (part == mkcl_core.empty_string) {  /* "/", ";" */
      if (j != start) {
	if (flags & WORD_LOGICAL)
	  return @':error';
	*end_of_dir = i;
	continue;
      }
      part = (flags & WORD_LOGICAL) ? @':relative' : @':absolute';
    }
    *end_of_dir = i;
    path = mkcl_cons(env, part, path);
  }
  return mk_cl_nreverse(env, path);
}

bool
mkcl_logical_hostname_p(MKCL, mkcl_object host)
{

  if ((host == mkcl_core.localhost_string) || !mkcl_stringp(env, host) || mkcl_string_E(env, host, mkcl_core.localhost_string))

    return FALSE;
  return !mkcl_Null(@assoc(env, 4, host, mkcl_core.pathname_translations, @':test', @'string-equal'));
}

/*
 * Parses a lisp namestring until the whole substring is parsed or an
 * error is found. It returns a valid pathname or NIL, plus the place
 * where parsing ended in *END_OF_PARSING.
 *
 * The rules are as follows:
 *
 * 1) If a hostname is supplied it determines whether the namestring
 *    will be parsed as logical or as physical.
 *
 * 2) If no hostname is supplied, first it tries parsing using logical
 *    pathname rules and, if no logical hostname is found, then it
 *    tries the physical pathname format.
 *
 * 3) Logical pathname syntax:
 *	[logical-hostname:][;][logical-directory-component;][pathname-name][.pathname-type]
 *
#if 0
 * 4) Physical pathname syntax:
 *	[device:][[//hostname]/][directory-component/]*[pathname-name][.pathname-type]
#else
 * 4a) Physical pathname syntax on Microsoft Windows:
 *	[device:[/]|//hostname/share/|/][directory-component/]*[pathname-name][.pathname-type]
 *
 * 4b) Physical pathname syntax on Unix (POSIX):
 *	[hostname:][/][directory-component/]*[pathname-name][.pathname-type]
#endif
 *
 *	logical-hostname, device, hostname = word
 *	logical-directory-component = word | wildcard-word
 *	directory-component = word | wildcard-word | '..' | '.'
 *	pathname-name, pathname-type = word | wildcard-word | ""
 *
 */
mkcl_object

mkcl_parse_namestring(MKCL, mkcl_object s, mkcl_index start, mkcl_index end, mkcl_index *ep,
                      mkcl_object default_host, enum mkcl_namestring_specificity specificity)

{
  mkcl_object host = @'nil';
  mkcl_object device = @'nil';
  mkcl_object dir = @'nil';
  mkcl_object name = @'nil';
  mkcl_object type = @'nil';
  mkcl_object version = @'nil';
  bool logical = FALSE;

  if ((start == end) || (mkcl_string_length(env, s) == 0)) {
    goto make_it;
  }

  /* We first try parsing as logical-pathname. In case of
   * failure, physical-pathname parsing is performed only when
   * there is no supplied *logical* host name. All other failures
   * result in mk_cl_Cnil as output.
   */
  host = parse_word(env, s, is_colon,
		    WORD_LOGICAL | WORD_INCLUDE_DELIM | WORD_DISALLOW_SEMICOLON,

		    start, end, ep, specificity);

  if (default_host != mk_cl_Cnil) {
    if (host == mk_cl_Cnil || host == @':error')
      host = default_host;
  }

  if ((host != @':error') && mkcl_logical_hostname_p(env, host))
    {
      /*
       * Logical pathname format:
       *	[logical-hostname :][;][logical-directory-component ;][pathname-name][. pathname-type [. version]]
       */
      logical = TRUE;
      device = @':unspecific';

      dir = parse_directories(env, s, WORD_LOGICAL, *ep, end, ep, specificity);

      if (dir == @':error')
	return mk_cl_Cnil;
      if (MKCL_CONSP(dir)) {
	if (MKCL_CONS_CAR(dir) != @':relative' &&
	    MKCL_CONS_CAR(dir) != @':absolute')
	  dir = MKCL_CONS(env, @':absolute', dir);
	dir = canonicalize_directory_destructively(env, dir, TRUE);
      } else {
	dir = MKCL_CONS(env, @':absolute', dir);
      }
      if (dir == @':error')
	return mk_cl_Cnil;
      name = parse_word(env, s, is_dot,
			WORD_LOGICAL | WORD_ALLOW_ASTERISK | WORD_EMPTY_IS_NIL,

			*ep, end, ep, specificity);

      if (name == @':error')
	return mk_cl_Cnil;
      type = mk_cl_Cnil;
      version = mk_cl_Cnil;
      if (*ep == start || mkcl_char(env, s, *ep-1) != '.')
	goto make_it;
      type = parse_word(env, s, is_dot,
			WORD_LOGICAL | WORD_ALLOW_ASTERISK | WORD_EMPTY_IS_NIL,

			*ep, end, ep, specificity);

      if (type == @':error')
	return mk_cl_Cnil;
      if (*ep == start || mkcl_char(env, s, *ep-1) != '.')
	goto make_it;

      mkcl_object aux;

      aux = parse_word(env, s, is_null,
		       WORD_LOGICAL | WORD_ALLOW_ASTERISK | WORD_EMPTY_IS_NIL,

		       *ep, end, ep, specificity);

      if (aux == @':error') {
	return mk_cl_Cnil;

      } else if (mkcl_Null(aux) || aux == @':wild') {

	version = aux;
      } else {
	version = mk_cl_parse_integer(env, 3, aux, @':junk-allowed', mk_cl_Ct);
	if (mk_cl_integerp(env, version) != mk_cl_Cnil && mkcl_plusp(env, version) &&
	    mkcl_fixnum_to_word(MKCL_VALUES(1)) == mkcl_length(env, aux))
	  ;
	else if (mk_cl_string_equal(env, 2, aux, @':newest') != mk_cl_Cnil)
	  version = @':newest';
	else
	  return mk_cl_Cnil;
      }
    }
  else
    {
    /* physical: */
      /*
#if 0
       * Physical pathname format:
       *	[[device:[//hostname]]/][directory-component/]*[pathname-name][.pathname-type]
#endif
       *
       * We would be a lot happier with this one on MS-Windows. JCB
       *  [device:[/]|//hostname/|/]{directory/}[.name|{name}+[.type]]
       *
       * And this one on Unix.
       *  [hostname:][/]{directory/}[.name|{name}+[.type]]
       *
       * And give up on the idea of a single format!
       * If the CL ANSI standard renounced that idea
       * long ago as most probably impossible why should
       * we even try? JCB
       */
      logical = FALSE;
#if defined(MKCL_WINDOWS)
      if ((start+1 <= end) && is_slash(mkcl_char(env, s, start))) {
	device = mk_cl_Cnil;
	goto maybe_parse_host;
      }
      device = parse_word(env, s, is_colon,
			  WORD_INCLUDE_DELIM | WORD_EMPTY_IS_NIL | WORD_DISALLOW_SLASH,

			  start, end, ep, specificity);

      if (device == @':error')
	{
	  device = mk_cl_Cnil;
	  host = mk_cl_Cnil;
	  goto done_device_and_host;
	}
      else if (device == mk_cl_Cnil)
	{
	  start = *ep;
	  host = mk_cl_Cnil;
	  goto done_device_and_host;
	}
      if (!mkcl_stringp(env, device)) {
	return mk_cl_Cnil;
      }
      else if (mkcl_length(env, device) == 0) /* This case (":/foobar") should not be accepted! JCB */
	device = mk_cl_Cnil;

    maybe_parse_host:
      if (!mkcl_Null(device))
	{ /* On MS-Windows host and device are mutually exclusive. */
	  host = mkcl_core.localhost_string;
	}
      else if ((start+2) <= end
	       && is_slash(mkcl_char(env, s, start))
	       && is_slash(mkcl_char(env, s, start+1))) /* Is this a UNC path? */
	{
	  mkcl_index head = start + 2;

	  if ((head + 2) <= end
	      && (mkcl_char(env, s, start) == '\\')
	      && (mkcl_char(env, s, start+1) == '\\')
	      && (mkcl_char(env, s, head) == '?')
	      && (mkcl_char(env, s, head+1) == '\\'))
	    {
	      /* This is an extended path string prefix. */
	      mkcl_character ch;

	      head += 2;
	      if ((head + 4) <= end
		  && (mkcl_char(env, s, head) == 'U')
		  && (mkcl_char(env, s, head+1) == 'N')
		  && (mkcl_char(env, s, head+2) == 'C')
		  && (mkcl_char(env, s, head+3) == '\\'))
		head += 4; /* This is the UNC form of the prefix. */
	      else if ((head + 2) <= end
		       && ((((ch = mkcl_char(env, s, head)) >= 'A')
			    && (ch <= 'Z'))
			   || ((ch >= 'a') && (ch <= 'z')))
		       && is_colon(mkcl_char(env, s, head+1)))
		{ /* This is the local drive form of prefix. */
		  device = mk_cl_make_string(env, 3, MKCL_MAKE_FIXNUM(1), @':initial-element', MKCL_CODE_CHAR(ch));
		  host = mkcl_core.localhost_string;
		  *ep = start = head + 2;
		  goto done_device_and_host;
		}
	    }

	  host = parse_word(env, s, is_slash, WORD_EMPTY_IS_NIL, head, end, ep, specificity);

	  if (host == @':error') {
	    host = mk_cl_Cnil;
	  } else if (host != mk_cl_Cnil) {
	    if (!mkcl_stringp(env, host))
	      return mk_cl_Cnil;
	    /* parse share name */

	    device = parse_word(env, s, is_slash, WORD_EMPTY_IS_NIL, *ep, end, ep, specificity);

	    start = *ep - 1;
	    if (is_slash(mkcl_char(env, s, start)))
	      *ep = start;
	  }
	}
      else
	host = mkcl_core.localhost_string;

#else /* defined(MKCL_WINDOWS) */
      host = mkcl_core.localhost_string;
      device = @':unspecific';       /* Files have no effective device on Unix. */
      {
	mkcl_object maybe_host = parse_word(env, s, is_colon,
					    WORD_INCLUDE_DELIM | WORD_EMPTY_IS_NIL | WORD_DISALLOW_SLASH,

					    start, end, ep, specificity);

	if (maybe_host == mk_cl_Cnil)
	  start = *ep;
	else if (maybe_host != @':error')
	  host = maybe_host;
      }
#endif /* else defined(MKCL_WINDOWS) */

      
    done_device_and_host:

      dir = parse_directories(env, s, 0, *ep, end, ep, specificity);

      if (MKCL_CONSP(dir)) {
	if (!(MKCL_CONS_CAR(dir) == @':relative'
	      || MKCL_CONS_CAR(dir) == @':absolute'))
	  dir = MKCL_CONS(env, @':relative', dir);
	dir = canonicalize_directory_destructively(env, dir, FALSE);
      }
      if (dir == @':error')
	return mk_cl_Cnil;
      start = *ep;
      name = parse_word(env, s, is_dot,
			WORD_ALLOW_LEADING_DOT | WORD_SEARCH_LAST_DOT |
			WORD_ALLOW_ASTERISK | WORD_EMPTY_IS_NIL,

			start, end, ep, specificity);

      if (name == @':error')
	return mk_cl_Cnil;
      if ((*ep - start) <= 1 || mkcl_char(env, s, *ep-1) != '.') {
	type = mk_cl_Cnil;
	if (mkcl_Null(dir) && !mkcl_Null(mk_cl_stringE(env, 2, name, mkcl_core.dot_string)))
	  {
	    dir = mkcl_list1(env, @':relative');
	    name = mk_cl_Cnil;
	  }
      } else {

	type = parse_word(env, s, is_null, WORD_ALLOW_ASTERISK, *ep, end, ep, specificity);