/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */

/*
 * 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) 2015 Daniel Kochmański
 *
 * See file 'LICENSE' for the copyright details.
 *
 */

/*
  O.S. DEPENDENT

  This file contains those functions that interpret namestrings.
*/

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

typedef int (*delim_fn)(int);

/*
 * Translates a string into the host's preferred case.
 * See CLHS 19.2.2.1.2.2 Common Case in Pathname Components.
 */
/* We use UN*X conventions, so lower case is default.
 * However, this really should be conditionalised to the OS type,
 * and it should translate to _opposite_ of the local case.
 */

static cl_object
normalize_case(cl_object path, cl_object cas)
{
  if (cas == @':local') {
    if (path->pathname.logical)
      return @':upcase';
    return @':downcase';
  } else if (cas == @':common' || cas == @':downcase' || cas == @':upcase') {
    return cas;
  } else {
    FEerror("Not a valid pathname case :~%~A", 1, cas);
  }
}

static bool
in_local_case_p(cl_object str, cl_object cas)
{
  if (cas == @':downcase')
    return ecl_string_case(str) < 0;
  return 1;
}

static bool
in_antilocal_case_p(cl_object str, cl_object cas)
{
  if (cas == @':downcase')
    return ecl_string_case(str) > 0;
  return 0;
}

static cl_object
to_local_case(cl_object str, cl_object cas)
{
  if (cas == @':downcase')
    return cl_string_downcase(1, str);
  return cl_string_upcase(1, str);
}

static cl_object
host_case(cl_object host)
{
  if (Null(host))
    return @':local';
  if (ecl_logical_hostname_p(host))
    return @':upcase';
  return @':downcase';
}

static cl_object
to_antilocal_case(cl_object str, cl_object cas)
{
  if (cas == @':downcase')
    return cl_string_upcase(1, str);
  return cl_string_upcase(1, str);
}

static cl_object
translate_from_common(cl_object str, cl_object tocase)
{
  int string_case = ecl_string_case(str);
  if (string_case > 0) { /* ALL_UPPER */
    return to_local_case(str, tocase);
  } else if (string_case < 0) { /* ALL_LOWER */
    return to_antilocal_case(str, tocase);
  } else { /* Mixed case goes unchanged */
    return str;
  }
}

static cl_object
translate_to_common(cl_object str, cl_object fromcase)
{
  if (in_local_case_p(str, fromcase)) {
    return cl_string_upcase(1, str);
  } else if (in_antilocal_case_p(str, fromcase)) {
    return cl_string_downcase(1, str);
  } else {
    return str;
  }
}

static cl_object
translate_component_case(cl_object str, cl_object fromcase, cl_object tocase)
{
  /* Pathnames may contain some other objects, such as symbols,
   * numbers, etc, which need not be translated */
  if (str == OBJNULL) {
    return str;
  } else if (!ECL_STRINGP(str)) {
    return str;
  } else if (tocase == fromcase) {
    return str;
  } else if (tocase == @':common') {
    return translate_to_common(str, fromcase);
  } else if (fromcase == @':common') {
    return translate_from_common(str, tocase);
  } else {
    str = translate_to_common(str, fromcase);
    return translate_from_common(str, tocase);
  }
}

static cl_object
translate_list_case(cl_object list, cl_object fromcase, cl_object tocase)
{
  /* 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 (!CONSP(list)) {
    return translate_component_case(list, fromcase, tocase);
  } else {
    cl_object l;
    list = cl_copy_list(list);
    for (l = list; !ecl_endp(l); l = CDR(l)) {
      /* It is safe to pass anything to translate_component_case,
       * because it will only transform strings, leaving other
       * object (such as symbols) unchanged.*/
      cl_object name = ECL_CONS_CAR(l);
      name = ECL_LISTP(name)?
        translate_list_case(name, fromcase, tocase) :
        translate_component_case(name, fromcase, tocase);
      ECL_RPLACA(l, name);
    }
    return list;
  }
}

static void
push_substring(cl_object buffer, cl_object string, cl_index start, cl_index end)
{
  string = cl_string(string);
  while (start < end) {
    ecl_string_push_extend(buffer, ecl_char(string, start));
    start++;
  }
}

static void
push_string(cl_object buffer, cl_object string)
{
  push_substring(buffer, string, 0, ecl_length(string));
}

static cl_object
destructively_check_directory(cl_object directory, bool logical, bool delete_back)
{
  /* This function performs two tasks
   * 1) It ensures that the list is a valid directory list
   * 2) It ensures that all strings in the list are valid C strings without fill pointer
   *    All strings are copied, thus avoiding problems with the user modifying the
   *    list that was passed to MAKE-PATHNAME.
   * 3) Redundant :back are removed.
   */
  /* INV: directory is always a list */
  cl_object ptr;
  int i;

  if (!LISTP(directory))
    return @':error';
  if (Null(directory))
    return directory;
  if (ECL_CONS_CAR(directory) != @':absolute' &&
      ECL_CONS_CAR(directory) != @':relative')
    return @':error';
 BEGIN:
  for (i=0, ptr=directory; CONSP(ptr); ptr = ECL_CONS_CDR(ptr), i++) {
    cl_object item = ECL_CONS_CAR(ptr);
    if (item == @':back') {
      if (i == 0)
        return @':error';
      item = ecl_nth(i-1, directory);
      if (item == @':absolute' || item == @':wild-inferiors')
        return @':error';
      if (delete_back && i >= 2) {
        cl_object next = ECL_CONS_CDR(ptr);
        ptr = ecl_nthcdr(i-2, directory);
        ECL_RPLACD(ptr, next);
        i = i-2;
      }
    } else if (item == @':up') {
      if (i == 0)
        return @':error';
      item = ecl_nth(i-1, directory);
      if (item == @':absolute' || item == @':wild-inferiors')
        return @':error';
    } else if (item == @':relative' || item == @':absolute') {
      if (i > 0)
        return @':error';
    } else if (ecl_stringp(item)) {
      cl_index l = ecl_length(item);
      item = cl_copy_seq(item);
      ECL_RPLACA(ptr, item);
      if (logical)
        continue;
      if (l && ecl_char(item,0) == '.') {
        if (l == 1) {
          /* Single dot */
          if (i == 0)
            return @':error';
          ECL_RPLACD(ecl_nthcdr(--i, directory),
                     ECL_CONS_CDR(ptr));
        } else if (l == 2 && ecl_char(item,1) == '.') {
          ECL_RPLACA(ptr, @':up');
          goto BEGIN;
        }
      }
    } else if (item != @':wild' && item != @':wild-inferiors') {
      return @':error';
    }
  }
  return directory;
}

cl_object
ecl_make_pathname(cl_object host, cl_object device, cl_object directory,
                  cl_object name, cl_object type, cl_object version,
                  cl_object fromcase)
{
  cl_object x, p, component;

  p = ecl_alloc_object(t_pathname);
  if (ecl_stringp(host))
    p->pathname.logical = ecl_logical_hostname_p(host);
  else if (host == ECL_NIL)
    p->pathname.logical = FALSE;
  else {
    x = directory;
    component = @':host';
    goto ERROR;
  }
  if (device != ECL_NIL && device != @':unspecific' &&
      !(!p->pathname.logical && ecl_stringp(device))) {
    x = device;
    component = @':device';
    goto ERROR;
  }
  if (name != ECL_NIL && name != @':wild' && !ecl_stringp(name)) {
    x = name;
    component = @':name';
    goto ERROR;
  }
  if (type != ECL_NIL && type != @':unspecific' && type != @':wild' && !ecl_stringp(type)) {
    x = type;
    component = @':type';
    goto ERROR;
  }
  if (version != @':unspecific' && version != @':newest' &&
      version != @':wild' && version != ECL_NIL && !ECL_FIXNUMP(version))
    {
      x = version;
      component = @':version';
    ERROR:  FEerror("~s is not a valid pathname-~a component", 2, x, component);
    }
  switch (ecl_t_of(directory)) {
#ifdef ECL_UNICODE
  case t_string:
#endif
  case t_base_string:
    directory = cl_list(2, @':absolute', directory);
    break;
  case t_symbol:
    if (directory == @':wild') {
      directory = cl_list(2, @':absolute', @':wild-inferiors');
      break;
    }
    x = directory;
    component = @':directory';
    goto ERROR;
  case t_list:
    directory = cl_copy_list(directory);
    break;
  default:
    x = directory;
    component = @':directory';
    goto ERROR;
  }
  p->pathname.host = host;
  {
    cl_object tocase = normalize_case(p, @':local');
    if (p->pathname.logical)
      fromcase = @':common';
    else
      fromcase = normalize_case(p, fromcase);
    p->pathname.host =
      translate_component_case(host, fromcase, tocase);
    p->pathname.device =
      translate_component_case(device, fromcase, tocase);
    p->pathname.directory =
      directory =
      translate_list_case(directory, fromcase, tocase);
    p->pathname.name =
      translate_component_case(name, fromcase, tocase);
    p->pathname.type =
      translate_component_case(type, fromcase, tocase);
    p->pathname.version = version;
  }
  directory = destructively_check_directory(directory, p->pathname.logical, 0);
  unlikely_if (directory == @':error') {
    cl_error(3, @'file-error', @':pathname', p);
  }
  p->pathname.directory = directory;
  return(p);
}

static cl_object
tilde_expand(cl_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.
   */
  cl_object directory, head;
  if (pathname->pathname.logical || pathname->pathname.host != ECL_NIL
      || pathname->pathname.device != ECL_NIL) {
    return pathname;
  }
  directory = pathname->pathname.directory;
  if (!CONSP(directory) || ECL_CONS_CAR(directory) != @':relative'
      || ECL_CONS_CDR(directory) == ECL_NIL) {
    return pathname;
  }
  head = CADR(directory);
  if (ecl_stringp(head) && ecl_length(head) > 0 && 
      ecl_char(head,0) == '~') {
    /* Remove the tilde component */
    ECL_RPLACD(directory, CDDR(directory));
    pathname = cl_merge_pathnames(2, pathname,
                                  ecl_homedir_pathname(head));
  }
  return pathname;
}

#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

static cl_object
make_one(cl_object s, cl_index start, cl_index end)
{
  return cl_subseq(3, s, ecl_make_fixnum(start), ecl_make_fixnum(end));
}

static int is_colon(int c) { return c == ':'; }
static int is_slash(int c) { return IS_DIR_SEPARATOR(c); }
static int is_semicolon(int c) { return c == ';'; }
static int is_dot(int c) { return c == '.'; }
static int is_null(int 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 ECL_NIL when word has no elements
 *      5) A non empty string
 */
static cl_object
parse_word(cl_object s, delim_fn delim, int flags, cl_index start,
           cl_index end, cl_index *end_of_word)
{
  cl_index i, j, last_delim = end;
  bool wild_inferiors = FALSE;

  i = j = start;
  for (; i < end; i++) {
    bool valid_char;
    cl_index c = ecl_char(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))
        valid_char = FALSE; /* Asterisks not allowed in this word */
      else {
        wild_inferiors = (i > start && ecl_char(s, i-1) == '*');
        valid_char = TRUE; /* single "*" */
      }
    } else if (c == ';' && (flags & WORD_DISALLOW_SEMICOLON)) {
      valid_char = 0;
    } else if (c == '/' && (flags & WORD_DISALLOW_SLASH)) {
      valid_char = 0;
    } else {
      valid_char = c != 0;
    }
    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 ECL_NIL;
    }
  }
  switch(i-j) {
  case 0:
    if (flags & WORD_EMPTY_IS_NIL)
      return ECL_NIL;
    return cl_core.null_string;
  case 1:
    if (ecl_char(s,j) == '*')
      return @':wild';
    break;
  case 2: {
    cl_index c0 = ecl_char(s,j);
    cl_index c1 = ecl_char(s,j+1);
    if (c0 == '*' && c1 == '*')
      return @':wild-inferiors';
    if (!(flags & WORD_LOGICAL) && c0 == '.' && c1 == '.')
      return @':up';
    break;
  }
  default:
    if (wild_inferiors)     /* '**' surrounded by other characters */
      return @':error';
  }
  return make_one(s, j, i);
}

/*
 * 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 cl_object
parse_directories(cl_object s, int flags, cl_index start, cl_index end,
                  cl_index *end_of_dir)
{
  cl_index i, j;
  cl_object path = ECL_NIL;
  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) {
    cl_object part = parse_word(s, delim, flags, j, end, &i);
    if (part == @':error' || part == ECL_NIL)
      break;
    if (part == cl_core.null_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 = ecl_cons(part, path);
  }
  return cl_nreverse(path);
}

bool
ecl_logical_hostname_p(cl_object host)
{
  if (!ecl_stringp(host))
    return FALSE;
  return !Null(@assoc(4, host, cl_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]
 *
 * 4) Physical pathname syntax:
 *      [device:][[//hostname]/][directory-component/]*[pathname-name][.pathname-type]
 *
 *      logical-hostname, device, hostname = word
 *      logical-directory-component = word | wildcard-word
 *      directory-component = word | wildcard-word | '..' | '.'
 *      pathname-name, pathname-type = word | wildcard-word | ""
 *
 */
cl_object
ecl_parse_namestring(cl_object s, cl_index start, cl_index end, cl_index *ep,
                     cl_object default_host)
{
  cl_object host, device, path, name, type, aux, version;
  bool logical;

  if (start == end) {
    host = device = path = name = type = aux = version = @'nil';
    logical = 0;
    *ep = end;
    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 ECL_NIL as output.
   */
  host = parse_word(s, is_colon, WORD_LOGICAL | WORD_INCLUDE_DELIM |
                    WORD_DISALLOW_SEMICOLON, start, end, ep);
  if (default_host != ECL_NIL) {
    if (host == ECL_NIL || host == @':error')
      host = default_host;
  }
  if (!ecl_logical_hostname_p(host))
    goto physical;
  /*
   * Logical pathname format:
   *      [logical-hostname:][;][logical-directory-component;][pathname-name][.pathname-type]
   */
  logical = TRUE;
  device = @':unspecific';
  path = parse_directories(s, WORD_LOGICAL, *ep, end, ep);
  if (CONSP(path)) {
    if (ECL_CONS_CAR(path) != @':relative' &&
        ECL_CONS_CAR(path) != @':absolute')
      path = CONS(@':absolute', path);
    path = destructively_check_directory(path, TRUE, FALSE);
  } else {
    path = CONS(@':absolute', path);
  }
  if (path == @':error')
    return ECL_NIL;
  name = parse_word(s, is_dot, WORD_LOGICAL | WORD_ALLOW_ASTERISK |
                    WORD_EMPTY_IS_NIL, *ep, end, ep);
  if (name == @':error')
    return ECL_NIL;
  type = ECL_NIL;
  version = ECL_NIL;
  if (*ep == start || ecl_char(s, *ep-1) != '.')
    goto make_it;
  type = parse_word(s, is_dot, WORD_LOGICAL | WORD_ALLOW_ASTERISK |
                    WORD_EMPTY_IS_NIL, *ep, end, ep);
  if (type == @':error')
    return ECL_NIL;
  if (*ep == start || ecl_char(s, *ep-1) != '.')
    goto make_it;
  aux = parse_word(s, is_null, WORD_LOGICAL | WORD_ALLOW_ASTERISK |
                   WORD_EMPTY_IS_NIL, *ep, end, ep);
  if (aux == @':error') {
    return ECL_NIL;
  } else if (ECL_SYMBOLP(aux)) {
    version = aux;
  } else {
    const cl_env_ptr the_env = ecl_process_env();
    cl_object parsed_length;
    version = cl_parse_integer(3, aux, @':junk-allowed', ECL_T);
    parsed_length = ecl_nth_value(the_env, 1);
    if (ecl_fixnum(parsed_length) == ecl_length(aux) &&
        cl_integerp(version) != ECL_NIL && ecl_plusp(version))
      ;
    else if (cl_string_equal(2, aux, @':newest') != ECL_NIL)
      version = @':newest';
    else
      return ECL_NIL;
  }
  goto make_it;
 physical:
  /*
   * Physical pathname format:
   *      [[device:[//hostname]]/][directory-component/]*[pathname-name][.pathname-type]
   */
  logical = FALSE;
  /* We only parse a hostname when the device was present. This
   * requisite is a bit stupid and only applies to the Unix port,
   * where "//home/" is equivalent to "/home" However, in Windows
   * we need "//FOO/" to be separately handled, for it is a shared
   * resource.
   */
#if defined(ECL_MS_WINDOWS_HOST)
  if ((start+1 <= end) && is_slash(ecl_char(s, start))) {
    device = ECL_NIL;
    goto maybe_parse_host;
  }
#endif
  device = parse_word(s, is_colon, WORD_INCLUDE_DELIM | WORD_EMPTY_IS_NIL |
                      WORD_DISALLOW_SLASH, start, end, ep);
  if (device == @':error' || device == ECL_NIL) {
    device = ECL_NIL;
    host = ECL_NIL;
    goto done_device_and_host;
  }
  if (!ecl_stringp(device)) {
    return ECL_NIL;
  }
 maybe_parse_host:
  /* Files have no effective device. */
  if (@string-equal(2, device, @':file') == ECL_T)
    device = ECL_NIL;
  start = *ep;
  host = ECL_NIL;
  if ((start+2) <= end && is_slash(ecl_char(s, start)) &&
      is_slash(ecl_char(s, start+1)))
    {
      host = parse_word(s, is_slash, WORD_EMPTY_IS_NIL,
                        start+2, end, ep);
      if (host == @':error') {
        host = ECL_NIL;
      } else if (host != ECL_NIL) {
        if (!ecl_stringp(host))
          return ECL_NIL;
        start = *ep;
        if (is_slash(ecl_char(s,--start)))
          *ep = start;
      }
    }
  if (ecl_length(device) == 0)
    device = ECL_NIL;
 done_device_and_host:
  path = parse_directories(s, 0, *ep, end, ep);
  if (CONSP(path)) {
    if (ECL_CONS_CAR(path) != @':relative' &&
        ECL_CONS_CAR(path) != @':absolute')
      path = CONS(@':relative', path);
    path = destructively_check_directory(path, FALSE, FALSE);
  }
  if (path == @':error')
    return ECL_NIL;
  start = *ep;
  name = parse_word(s, is_dot,
                    WORD_ALLOW_LEADING_DOT | WORD_SEARCH_LAST_DOT |
                    WORD_ALLOW_ASTERISK | WORD_EMPTY_IS_NIL,
                    start, end, ep);
  if (name == @':error')
    return ECL_NIL;
  if ((*ep - start) <= 1 || ecl_char(s, *ep-1) != '.') {
    type = ECL_NIL;
  } else {
    type = parse_word(s, is_null, WORD_ALLOW_ASTERISK, *ep, end, ep);
    if (type == @':error')
      return ECL_NIL;
  }
  version = (name != ECL_NIL || type != ECL_NIL) ? @':newest' : ECL_NIL;
 make_it:
  if (*ep >= end) *ep = end;
  path = ecl_make_pathname(host, device, path, name, type, version,
                           @':local');
  path->pathname.logical = logical;
  return tilde_expand(path);
}

cl_object
si_default_pathname_defaults(void)
{
  /* This routine outputs the value of *default-pathname-defaults*
   * coerced to type PATHNAME. Special care is taken so that we do
   * not enter an infinite loop when using PARSE-NAMESTRING, because
   * this routine might itself try to use the value of this variable. */
  cl_object path = ecl_symbol_value(@'*default-pathname-defaults*');
  unlikely_if (!ECL_PATHNAMEP(path)) {
    const cl_env_ptr the_env = ecl_process_env();
    ecl_bds_bind(the_env, @'*default-pathname-defaults*', si_getcwd(0));
    FEwrong_type_key_arg(@[pathname], @[*default-pathname-defaults*],
                         path, @'pathname');
  }
  @(return path);
}

cl_object
cl_pathname(cl_object x)
{
 L:
  switch (ecl_t_of(x)) {
#ifdef ECL_UNICODE
  case t_string:
#endif
  case t_base_string:
    x = cl_parse_namestring(1, x);
  case t_pathname:
    break;
  case t_stream:
    switch ((enum ecl_smmode)x->stream.mode) {
    case ecl_smm_input:
    case ecl_smm_output:
    case ecl_smm_probe:
    case ecl_smm_io:
    case ecl_smm_input_file:
    case ecl_smm_output_file:
    case ecl_smm_io_file:
      x = IO_STREAM_FILENAME(x);
      goto L;
    case ecl_smm_synonym:
      x = SYNONYM_STREAM_STREAM(x);
      goto L;
    default:
      ;/* Fall through to error message */
    }
  default: {
    const char *type = "(OR FILE-STREAM STRING PATHNAME)";
    FEwrong_type_only_arg(@[pathname], x, ecl_read_from_cstring(type));
  }
  }
  @(return x);
}

cl_object
cl_logical_pathname(cl_object x)
{
  x = cl_pathname(x);
  if (!x->pathname.logical) {
    cl_error(9, @'simple-type-error', @':format-control',
             ecl_make_constant_base_string("~S cannot be coerced to a logical pathname.",-1),
             @':format-arguments', cl_list(1, x),
             @':expected-type', @'logical-pathname',
             @':datum', x);
  }
  @(return x);
}

/* FIXME! WILD-PATHNAME-P is missing! */
@(defun wild-pathname-p (pathname &optional component)
  bool checked = 0;
@
  pathname = cl_pathname(pathname);
  if (component == ECL_NIL || component == @':host') {
    if (pathname->pathname.host == @':wild') {
      @(return ECL_T);
    }
    checked = 1;
  }
  if (component == ECL_NIL || component == @':device') {
    if (pathname->pathname.device == @':wild') {
      @(return ECL_T);
    }
    checked = 1;
  }
  if (component == ECL_NIL || component == @':version') {
    if (pathname->pathname.version == @':wild') {
      @(return ECL_T);
    }
    checked = 1;
  }
  if (component == ECL_NIL || component == @':name') {
    cl_object name = pathname->pathname.name;
    if (name != ECL_NIL &&
        (name == @':wild' || ecl_wild_string_p(name))) {
      @(return ECL_T);
    }
    checked = 1;
  }
  if (component == ECL_NIL || component == @':type') {
    cl_object name = pathname->pathname.type;
    if (name != ECL_NIL &&
        (name == @':wild' || ecl_wild_string_p(name))) {
      @(return ECL_T);
    }
    checked = 1;
  }
  if (component == ECL_NIL || component == @':directory') {
    cl_object list = pathname->pathname.directory;
    checked = 1;
    loop_for_on_unsafe(list) {
      cl_object name = ECL_CONS_CAR(list);
      if (name != ECL_NIL &&
          (name == @':wild' || name == @':wild-inferiors' ||
           ecl_wild_string_p(name))) {
          @(return ECL_T);
        }
    } end_loop_for_on_unsafe(list);
  }
  if (checked == 0) {
    FEerror("~A is not a valid pathname component", 1, component);
  }
  @(return ECL_NIL);
@)

/*
 * coerce_to_file_pathname(P) converts P to a physical pathname,
 * for a file which is accesible in our filesystem.
 * INV: Wildcards are allowed.
 * INV: A fresh new copy of the pathname is created.
 * INV: The pathname is absolute.
 */
cl_object
coerce_to_file_pathname(cl_object pathname)
{
  pathname = coerce_to_physical_pathname(pathname);
  pathname = cl_merge_pathnames(1, pathname);
#if 0
#if !defined(cygwin) && !defined(ECL_MS_WINDOWS_HOST)
  if (pathname->pathname.device != ECL_NIL)
    FEerror("Device ~S not yet supported.", 1,
            pathname->pathname.device);
  if (pathname->pathname.host != ECL_NIL)
    FEerror("Access to remote files not yet supported.", 0);
#endif
#endif
  if (pathname->pathname.directory == ECL_NIL ||
      ECL_CONS_CAR(pathname->pathname.directory) == @':relative') {
    pathname = cl_merge_pathnames(2, pathname, si_getcwd(0));
  }
  return pathname;
}

/*
 * coerce_to_physical_pathname(P) converts P to a physical pathname,
 * performing the appropiate transformation if P was a logical pathname.
 */
cl_object
coerce_to_physical_pathname(cl_object x)
{
  x = cl_pathname(x);
  if (x->pathname.logical)
    return cl_translate_logical_pathname(1, x);
  return x;
}

/*
 * si_coerce_to_filename(P) converts P to a physical pathname and then to
 * a namestring. The output must always be a new simple-string which can
 * be used by the C library.
 * INV: No wildcards are allowed.
 */
cl_object
si_coerce_to_filename(cl_object pathname_orig)
{
  cl_object namestring, pathname;

  /* We always go through the pathname representation and thus
   * cl_namestring() always outputs a fresh new string */
  pathname = coerce_to_file_pathname(pathname_orig);
  if (cl_wild_pathname_p(1,pathname) != ECL_NIL)
    cl_error(3, @'file-error', @':pathname', pathname_orig);
  namestring = ecl_namestring(pathname,
                              ECL_NAMESTRING_TRUNCATE_IF_ERROR |
                              ECL_NAMESTRING_FORCE_BASE_STRING);
  if (namestring == ECL_NIL) {
    FEerror("Pathname without a physical namestring:"
            "~% :HOST ~A"
            "~% :DEVICE ~A"
            "~% :DIRECTORY ~A"
            "~% :NAME ~A"
            "~% :TYPE ~A"
            "~% :VERSION ~A",
            6, pathname_orig->pathname.host,
            pathname_orig->pathname.device,
            pathname_orig->pathname.directory,
            pathname_orig->pathname.name,
            pathname_orig->pathname.type,
            pathname_orig->pathname.version);
  }
  if (cl_core.path_max != -1 &&
      ecl_length(namestring) >= cl_core.path_max - 16)
    FEerror("Too long filename: ~S.", 1, namestring);
  return namestring;
}

#define default_device(host) ECL_NIL

cl_object
ecl_merge_pathnames(cl_object path, cl_object defaults, cl_object default_version)
{
  cl_object host, device, directory, name, type, version;
  cl_object tocase;

  defaults = cl_pathname(defaults);
  path = cl_parse_namestring(1, path, ECL_NIL, defaults);
  if (Null(host = path->pathname.host))
    host = defaults->pathname.host;
  tocase = host_case(host);
  if (Null(path->pathname.device)) {
    if (Null(path->pathname.host))
      device = cl_pathname_device(3, defaults, @':case', tocase);
    else if (path->pathname.host == defaults->pathname.host)
      device = defaults->pathname.device;
    else
      device = default_device(path->pathname.host);
  } else {
    device = path->pathname.device;
  }
  if (Null(path->pathname.directory)) {
    directory = cl_pathname_directory(3, defaults, @':case', tocase);
  } else if (ECL_CONS_CAR(path->pathname.directory) == @':absolute') {
    directory = path->pathname.directory;
  } else if (!Null(defaults->pathname.directory)) {
    directory = ecl_append(cl_pathname_directory(3, defaults,
                                                 @':case', tocase),
                           CDR(path->pathname.directory));
    /* Eliminate redundant :back */
    directory = destructively_check_directory(directory, TRUE, TRUE);
  } else {
    directory = path->pathname.directory;
  }
  if (Null(name = path->pathname.name)) {
    name = cl_pathname_name(3, defaults, @':case', tocase);
  }
  if (Null(type = path->pathname.type)) {
    type = cl_pathname_type(3, defaults, @':case', tocase);
  }
  version = path->pathname.version;
  if (Null(path->pathname.name)) {
    if (Null(version))
      version = defaults->pathname.version;
  }
  if (Null(version)) {
    version = default_version;
  }
  if (default_version == @':default') {
    if (Null(name) && Null(type)) {
      version = ECL_NIL;
    } else {
      version = @':newest';
    }
  }
  /*
    In this implementation, version is not considered
  */
  defaults = ecl_make_pathname(host, device, directory, name,
                               type, version, tocase);
  return defaults;
}

/*
  ecl_namestring(x, flag) converts a pathname to a namestring.
  if flag is true, then the pathname may be coerced to the requirements
  of the filesystem, removing fields that have no meaning (such as
  version, or type, etc); otherwise, when it is not possible to
  produce a readable representation of the pathname, NIL is returned.
*/
cl_object
ecl_namestring(cl_object x, int flags)
{
  bool logical;
  cl_object l, y;
  cl_object buffer, host;
  bool truncate_if_unreadable = flags & ECL_NAMESTRING_TRUNCATE_IF_ERROR;

  x = cl_pathname(x);

  /* INV: Pathnames can only be created by mergin, parsing namestrings
   * or using ecl_make_pathname(). In all of these cases ECL will complain
   * at creation time if the pathname has wrong components.
   */
  buffer = ecl_make_string_output_stream(128, 1);
  logical = x->pathname.logical;
  host = x->pathname.host;
  if (logical) {
    if ((y = x->pathname.device) != @':unspecific' &&
        truncate_if_unreadable)
      return ECL_NIL;
    if (host != ECL_NIL) {
      si_do_write_sequence(host, buffer, ecl_make_fixnum(0), ECL_NIL);
      writestr_stream(":", buffer);
    }
  } else {
    if ((y = x->pathname.device) != ECL_NIL) {
      si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL);
      writestr_stream(":", buffer);
    }
    if (host != ECL_NIL) {
#if !defined(ECL_MS_WINDOWS_HOST)
      if (y == ECL_NIL) {
        writestr_stream("file:", buffer);
      }
#endif
      writestr_stream("//", buffer);
      si_do_write_sequence(host, buffer, ecl_make_fixnum(0), ECL_NIL);
    }
  }
  l = x->pathname.directory;
  if (ecl_endp(l))
    goto NO_DIRECTORY;
  y = ECL_CONS_CAR(l);
  if (y == @':relative') {
    if (logical)
      ecl_write_char(';', buffer);
  } else {
    if (!logical)
      ecl_write_char(DIR_SEPARATOR, buffer);
  }
  l = ECL_CONS_CDR(l);
  loop_for_in(l) {
    y = ECL_CONS_CAR(l);
    if (y == @':up') {
      writestr_stream("..", buffer);
    } else if (y == @':wild') {
      writestr_stream("*", buffer);
    } else if (y == @':wild-inferiors') {
      writestr_stream("**", buffer);
    } else if (y != @':back') {
      si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL);
    } else {
      /* Directory :back has no namestring representation */
      return ECL_NIL;
    }
    ecl_write_char(logical? ';' : DIR_SEPARATOR, buffer);
  } end_loop_for_in;
 NO_DIRECTORY:
  if (ecl_file_position(buffer) == ecl_make_fixnum(0)) {
    if ((ecl_stringp(x->pathname.name) &&
         ecl_member_char(':', x->pathname.name)) ||
        (ecl_stringp(x->pathname.type) &&
         ecl_member_char(':', x->pathname.type)))
      writestr_stream(":", buffer);
  }
  y = x->pathname.name;
  if (y != ECL_NIL) {
    if (y == @':wild') {
      writestr_stream("*", buffer);
    } else {
      si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL);
    }
  } else if (!logical && !Null(x->pathname.type)) {
    /* #P".txt" is :NAME = ".txt" :TYPE = NIL and
       hence :NAME = NIL and :TYPE != NIL does not have
       a printed representation */
    return ECL_NIL;
  }
  y = x->pathname.type;
  if (y == @':unspecific') {
    return ECL_NIL;
  } else if (y != ECL_NIL) {
    if (y == @':wild') {
      writestr_stream(".*", buffer);
    } else {
      writestr_stream(".", buffer);
      si_do_write_sequence(y, buffer, ecl_make_fixnum(0), ECL_NIL);
    }
  }
  y = x->pathname.version;
  if (logical) {
    if (y != ECL_NIL) {
      writestr_stream(".", buffer);
      if (y == @':wild') {
        writestr_stream("*", buffer);
      } else if (y == @':newest') {
        si_do_write_sequence(ecl_symbol_name(y), buffer,
                             ecl_make_fixnum(0), ECL_NIL);
      } else {
        /* Since the printer is not reentrant,
         * we cannot use cl_write and friends.
         */
        int n = ecl_fixnum(y), i;
        char b[ECL_FIXNUM_BITS / 2];
        for (i = 0; n; i++) {
          b[i] = n%10 + '0';
          n = n/10;
        }
        if (i == 0)
          b[i++] = '0';
        while (i--) {
          ecl_write_char(b[i], buffer);
        }
      }
    }
  } else if (!truncate_if_unreadable) {
    /* Namestrings of physical pathnames have restrictions... */
    if (Null(x->pathname.name) && Null(x->pathname.type)) {
      /* Directories cannot have a version number */
      if (y != ECL_NIL)
        return ECL_NIL;
    } else if (y != @':newest') {
      /* Filenames have an implicit version :newest */
      return ECL_NIL;
    }
  }
  buffer = cl_get_output_stream_string(buffer);
#ifdef ECL_UNICODE
  if (ECL_EXTENDED_STRING_P(buffer) &&
      (flags & ECL_NAMESTRING_FORCE_BASE_STRING)) {
    unlikely_if (!ecl_fits_in_base_string(buffer))
      FEerror("The filesystem does not accept filenames "
              "with extended characters: ~S",
              1, buffer);
    buffer = si_copy_to_simple_base_string(buffer);
  }
#endif
  return buffer;
}

cl_object
cl_namestring(cl_object x)
{
  @(return ecl_namestring(x, ECL_NAMESTRING_TRUNCATE_IF_ERROR));
}

@(defun parse_namestring (thing
                          &o host (defaults si_default_pathname_defaults())
                          &k (start ecl_make_fixnum(0)) end junk_allowed
                          &a output)
@
  if (host != ECL_NIL) {
    host = cl_string(host);
  }
  if (!ecl_stringp(thing)) {
    output = cl_pathname(thing);
  } else {
    cl_object default_host = host;
    cl_index_pair p;
    cl_index ee;
    if (default_host == ECL_NIL && defaults != ECL_NIL) {
      defaults = cl_pathname(defaults);
      default_host = defaults->pathname.host;
    }
    p = ecl_vector_start_end(@[parse-namestring], thing, start, end);
    output = ecl_parse_namestring(thing, p.start, p.end, &ee, default_host);
    start = ecl_make_fixnum(ee);
    if (output == ECL_NIL || ee != p.end) {
      if (Null(junk_allowed)) {
        FEparse_error("Cannot parse the namestring ~S~%"
                      "from ~S to ~S.", ECL_NIL,
                      3, thing, start, end);
      }
      goto OUTPUT;
    }
  }
  if (host != ECL_NIL && !ecl_equal(output->pathname.host, host)) {
    FEerror("The pathname ~S does not contain the required host ~S.",
            2, thing, host);
  }
 OUTPUT:
  @(return output start);
@)

@(defun merge_pathnames (path
                         &o (defaults si_default_pathname_defaults())
                         (default_version @':newest'))
@
  path = cl_pathname(path);
  defaults = cl_pathname(defaults);
  @(return ecl_merge_pathnames(path, defaults, default_version));
@)

@(defun make_pathname (&key (host ECL_NIL hostp) (device ECL_NIL devicep)
                       (directory ECL_NIL directoryp)
                       (name ECL_NIL namep) (type ECL_NIL typep) (version ECL_NIL versionp)
                       ((:case scase) @':local')
                       defaults
                       &aux x)
@
  if (Null(defaults)) {
    defaults = si_default_pathname_defaults();
    defaults = ecl_make_pathname(defaults->pathname.host,
                                 ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL, ECL_NIL,
                                 @':local');
  } else {
    defaults = cl_pathname(defaults);
  }
  if (!hostp) host = defaults->pathname.host;
  x = ecl_make_pathname(host, device, directory, name, type, version, scase);
  if (!devicep) x->pathname.device = defaults->pathname.device;
  if (!directoryp) x->pathname.directory = defaults->pathname.directory;
  if (!namep) x->pathname.name = defaults->pathname.name;
  if (!typep) x->pathname.type = defaults->pathname.type;
  if (!versionp) x->pathname.version = defaults->pathname.version;

  @(return x);
@)

cl_object
cl_pathnamep(cl_object pname)
{
  @(return (ECL_PATHNAMEP(pname) ? ECL_T : ECL_NIL));
}

cl_object
si_logical_pathname_p(cl_object pname)
{
  @(return ((ECL_PATHNAMEP(pname) && pname->pathname.logical)?
            ECL_T : ECL_NIL));
}

@(defun pathname_host (pname &key ((:case scase) @':local'))
@
  pname = cl_pathname(pname);
  @(return translate_component_case(pname->pathname.host,
                                    normalize_case(pname, @':local'),
                                    normalize_case(pname, scase)));
@)

@(defun pathname_device (pname &key ((:case scase) @':local'))
@
  pname = cl_pathname(pname);
  @(return translate_component_case(pname->pathname.device,
                                    normalize_case(pname, @':local'),
                                    normalize_case(pname, scase)));
@)

@(defun pathname_directory (pname &key ((:case scase) @':local'))
@
  pname = cl_pathname(pname);
  @(return translate_list_case(pname->pathname.directory,
                               normalize_case(pname, @':local'),
                               normalize_case(pname, scase)));
@)

@(defun pathname_name(pname &key ((:case scase) @':local'))
@
  pname = cl_pathname(pname);
  @(return translate_component_case(pname->pathname.name,
                                    normalize_case(pname, @':local'),
                                    normalize_case(pname, scase)));
@)

@(defun pathname_type(pname &key ((:case scase) @':local'))
@
  pname = cl_pathname(pname);
  @(return translate_component_case(pname->pathname.type,
                                    normalize_case(pname, @':local'),
                                    normalize_case(pname, scase)));
@)

cl_object
cl_pathname_version(cl_object pname)
{
  pname = cl_pathname(pname);
  @(return  pname->pathname.version);
}

cl_object
cl_file_namestring(cl_object pname)
{
  pname = cl_pathname(pname);
  @(return ecl_namestring(ecl_make_pathname(ECL_NIL, ECL_NIL, ECL_NIL,
                                            pname->pathname.name,
                                            pname->pathname.type,
                                            pname->pathname.version,
                                            @':local'),
                          ECL_NAMESTRING_TRUNCATE_IF_ERROR));
}

cl_object
cl_directory_namestring(cl_object pname)
{
  pname = cl_pathname(pname);
  @(return ecl_namestring(ecl_make_pathname(ECL_NIL, ECL_NIL,
                                            pname->pathname.directory,
                                            ECL_NIL, ECL_NIL, ECL_NIL,
                                            @':local'),
                          ECL_NAMESTRING_TRUNCATE_IF_ERROR));
}

cl_object
cl_host_namestring(cl_object pname)
{
  pname = cl_pathname(pname);
  pname = pname->pathname.host;
  if (Null(pname) || pname == @':wild')
    pname = cl_core.null_string;
  @(return pname);
}

#define EN_MATCH(p1,p2,el) (ecl_equalp(p1->pathname.el, p2->pathname.el)? ECL_NIL : p1->pathname.el)

@(defun enough_namestring (path
                           &o (defaults si_default_pathname_defaults()))
  cl_object newpath, pathdir, defaultdir, fname;
@
  defaults = cl_pathname(defaults);
  path = cl_pathname(path);
  pathdir = path->pathname.directory;
  defaultdir = defaults->pathname.directory;
  if (Null(pathdir)) {
    pathdir = ecl_list1(@':relative');
  } else if (Null(defaultdir)) {
    /* The defaults pathname does not have a directory. */
  } else if (ECL_CONS_CAR(pathdir) == @':relative') {
    /* The pathname is relative to the default one one, so we just output the
       original one */
  } else {
    /* The new pathname is an absolute one. We compare it with the defaults
       and if they have some common elements, we just output the remaining ones. */
    cl_object dir_begin = funcall(5, @'mismatch', pathdir, defaultdir,
                                  @':test', @'equal');
    if (dir_begin == ECL_NIL) {
      pathdir = ECL_NIL;
    } else if (dir_begin == cl_length(defaultdir)) {
      pathdir = funcall(3, @'subseq', pathdir, dir_begin);
      pathdir = CONS(@':relative', pathdir);
    }
  }
  fname = EN_MATCH(path, defaults, name);
  if (fname == ECL_NIL) fname = path->pathname.name;
  /* Create a path with all elements that do not match the default */
  newpath = ecl_make_pathname(EN_MATCH(path, defaults, host),
                              EN_MATCH(path, defaults, device),
                              pathdir, fname,
                              EN_MATCH(path, defaults, type),
                              EN_MATCH(path, defaults, version),
                              @':local');
  newpath->pathname.logical = path->pathname.logical;
  @(return ecl_namestring(newpath, ECL_NAMESTRING_TRUNCATE_IF_ERROR));
@)
#undef EN_MATCH

/* --------------- PATHNAME MATCHING ------------------ */

bool
ecl_wild_string_p(cl_object item)
{
  if (ECL_STRINGP(item)) {
    cl_index i, l = ecl_length(item);
    for (i = 0; i < l; i++) {
      ecl_character c = ecl_char(item, i);
      if (c == '\\' || c == '*' || c == '?')
        return 1;
    }
  }
  return 0;
}

/*
 * Take two C strings and check if the first (s) one matches against
 * the pattern given by the second one (p). The pattern is that of a
 * Unix shell except for brackets and curly braces
 */
bool
ecl_string_match(cl_object s, cl_index j, cl_index ls,
                 cl_object p, cl_index i, cl_index lp)
{
  while (i < lp) {
    cl_index cp = ecl_char(p, i);
    switch (cp) {
    case '*': {
      /* An asterisk in the pattern matches any
       * number of characters. We try the shortest
       * sequence that matches. */
      cl_index cn = 0, next;
      for (next = i+1;
           next < lp && ((cn = ecl_char(p, next)) == '*');
           next++)
        ;
      if (next == lp) {
        return TRUE;
      }
      while (j < ls) {
        if (ecl_string_match(s, j, ls, p, next, lp)) {
          return TRUE;
        }
        j++;
      }
      return FALSE;
      break;
    }
    case '?':
      /* Match any character */
      if (j >= ls) return FALSE;
      i++; j++;
      break;
    case '\\':
      /* Interpret a pattern character literally.
         Trailing slash is interpreted as a slash. */
      if (++i >= lp) i--;
    default:
      if ((j >= ls) || (cp != ecl_char(s, j))) {
        /* Either there are no characters left in "s"
         * or the next character does not match. */
        return FALSE;
      }
      i++; j++;
    }
  }
  /* At the end all characters should have been matched */
  return (j >= ls);
}

static bool
path_item_match(cl_object a, cl_object mask) {
  if (mask == @':wild')
    return TRUE;
  /* If a component in the tested path is a wildcard field, this
     can only be matched by the same wildcard field in the mask */
  if (!ecl_stringp(a) || mask == ECL_NIL)
    return (a == mask);
  if (!ecl_stringp(mask))
    FEerror("~S is not supported as mask for pathname-match-p", 1, mask);
  return ecl_string_match(a, 0, ecl_length(a),
                          mask, 0, ecl_length(mask));
}

static bool
path_list_match(cl_object a, cl_object mask) {
  cl_object item_mask;
  while (!ecl_endp(mask)) {
    item_mask = CAR(mask);
    mask = CDR(mask);
    if (item_mask == @':wild-inferiors') {
      if (ecl_endp(mask))
        return TRUE;
      while (!ecl_endp(a)) {
        if (path_list_match(a, mask))
          return TRUE;
        a = CDR(a);
      }
      return FALSE;
    } else if (ecl_endp(a)) {
      /* A NIL directory should match against :absolute
         or :relative, in order to perform suitable translations. */
      if (item_mask != @':absolute' && item_mask != @':relative')
        return FALSE;
    } else if (!path_item_match(CAR(a), item_mask)) {
      return FALSE;
    } else {
      a = CDR(a);
    }
  }
  if (!ecl_endp(a))
    return FALSE;
  return TRUE;
}

cl_object
cl_pathname_match_p(cl_object path, cl_object mask)
{
  cl_object output = ECL_NIL;
  path = cl_pathname(path);
  mask = cl_pathname(mask);
  if (path->pathname.logical != mask->pathname.logical)
    goto OUTPUT;
#if 0
  /* INV: This was checked in the calling routine */
  if (!path_item_match(path->pathname.host, mask->pathname.host))
    goto OUTPUT;
#endif
  /* Missing components default to :WILD */
  if (!Null(mask->pathname.directory) &&
      !path_list_match(path->pathname.directory, mask->pathname.directory))
    goto OUTPUT;
  if (!path_item_match(path->pathname.name, mask->pathname.name))
    goto OUTPUT;
  if (!path_item_match(path->pathname.type, mask->pathname.type))
    goto OUTPUT;
  if (Null(mask->pathname.version) ||
      path_item_match(path->pathname.version, mask->pathname.version))
    output = ECL_T;
 OUTPUT:
  @(return output);
}

/* --------------- PATHNAME TRANSLATIONS ------------------ */

static cl_object
coerce_to_from_pathname(cl_object x, cl_object host)
{
  switch (ecl_t_of(x)) {
#ifdef ECL_UNICODE
  case t_string:
#endif
  case t_base_string:
    x = cl_parse_namestring(2, x, host);
  case t_pathname:
    if (x->pathname.logical)
      return x;
  default:
    FEerror("~S is not a valid from-pathname translation", 1, x);
  }
}

@(defun si::pathname-translations (host &optional (set OBJNULL))
  cl_index parsed_len, len;
  cl_object pair, l;
@
  /* Check that host is a valid host name */
  if (ecl_unlikely(!ECL_STRINGP(host)))
  FEwrong_type_nth_arg(@[si::pathname-translations], 1, host, @[string]);
  host = cl_string_upcase(1, host);
  len = ecl_length(host);
  parse_word(host, is_null, WORD_LOGICAL, 0, len, &parsed_len);
  if (parsed_len < len) {
    FEerror("Wrong host syntax ~S", 1, host);
  }
  /* Find its translation list */
  pair = @assoc(4, host, cl_core.pathname_translations, @':test', @'string-equal');
  if (set == OBJNULL) {
    @(return ((pair == ECL_NIL)? ECL_NIL : CADR(pair)));
  }
  /* Set the new translation list */
  if (ecl_unlikely(!LISTP(set))) {
    FEwrong_type_nth_arg(@[si::pathname-translations], 2, set, @[list]);
  }
  if (pair == ECL_NIL) {
    pair = CONS(host, CONS(ECL_NIL, ECL_NIL));
    cl_core.pathname_translations = CONS(pair, cl_core.pathname_translations);
  }
  for (l = set, set = ECL_NIL; !ecl_endp(l); l = CDR(l)) {
    cl_object item = CAR(l);
    cl_object from = coerce_to_from_pathname(cl_car(item), host);
    cl_object to = cl_pathname(cl_cadr(item));
    set = CONS(CONS(from, CONS(to, ECL_NIL)), set);
  }
  set = cl_nreverse(set);
  ECL_RPLACA(ECL_CONS_CDR(pair), set);
  @(return set);
@)

static cl_object
find_wilds(cl_object l, cl_object source, cl_object match)
{
  cl_index i, j, k, ls, lm;

  if (match == @':wild')
    return ecl_list1(source);
  if (!ecl_stringp(match) || !ecl_stringp(source)) {
    if (match != source)
      return @':error';
    return l;
  }
  ls = ecl_length(source);
  lm = ecl_length(match);
  for(i = j = 0; i < ls && j < lm; ) {
    cl_index pattern_char = ecl_char(match,j);
    if (pattern_char == '*') {
      for (j++, k = i;
           k < ls && ecl_char(source,k) != pattern_char;
           k++)
        ;
      l = CONS(make_one(source, i, k), l);
      i = k;
      continue;
    }
    if (ecl_char(source,i) != pattern_char)
      return @':error';
    i++, j++;
  }
  if (i < ls || j < lm)
    return @':error';
  return l;
}

static cl_object
find_list_wilds(cl_object a, cl_object mask)
{
  cl_object l = ECL_NIL, l2;

  while (!ecl_endp(mask)) {
    cl_object item_mask = CAR(mask);
    mask = CDR(mask);
    if (item_mask == @':wild-inferiors') {
      l2 = ECL_NIL;
      while (!path_list_match(a, mask)) {
        if (ecl_endp(a))
          return @':error';
        l2 = CONS(CAR(a),l2);
        a = CDR(a);
      }
      l = CONS(l2, l);
    } else if (ecl_endp(a)) {
      /* A NIL directory should match against :absolute
         or :relative, in order to perform suitable translations. */
      if (item_mask != @':absolute' && item_mask != @':relative')
        return @':error';
    } else {
      l2 = find_wilds(l, CAR(a), item_mask);
      if (l == @':error')
        return @':error';
      if (!Null(l2))
        l = CONS(l2, l);
      a = CDR(a);
    }
  }
  return @nreverse(l);
}

static cl_object
copy_wildcards(cl_object *wilds_list, cl_object pattern)
{
  cl_index i, l, j;
  bool new_string;
  cl_object wilds = *wilds_list, token;

  if (pattern == @':wild') {
    if (ecl_endp(wilds))
      return @':error';
    pattern = CAR(wilds);
    *wilds_list = CDR(wilds);
    return pattern;
  }
  if (pattern == @':wild-inferiors')
    return @':error';
  if (!ecl_stringp(pattern))
    return pattern;

  new_string = FALSE;
  l = ecl_length(pattern);
  token = si_get_buffer_string();
  for (j = i = 0; i < l; ) {
    cl_index c = ecl_char(pattern, i);
    if (c != '*') {
      i++;
      continue;
    }
    if (i != j) {
      push_substring(token, pattern, j, i);
    }
    new_string = TRUE;
    if (ecl_endp(wilds)) {
      return @':error';
    }
    push_string(token, CAR(wilds));
    wilds = CDR(wilds);
    j = i++;
  }
  /* Only create a new string when needed */
  if (new_string) {
    pattern = cl_copy_seq(token);
  }
  si_put_buffer_string(token);
  *wilds_list = wilds;
  return pattern;
}

static cl_object
copy_list_wildcards(cl_object *wilds, cl_object to)
{
  cl_object l = ECL_NIL;

  while (!ecl_endp(to)) {
    cl_object d, mask = CAR(to);
    if (mask == @':wild-inferiors') {
      cl_object list = *wilds;
      if (ecl_endp(list))
        return @':error';
      else {
        cl_object dirlist = CAR(list);
        if (CONSP(dirlist))
          l = ecl_append(CAR(list), l);
        else if (!Null(CAR(list)))
          return @':error';
      }
      *wilds = CDR(list);
    } else {
      d = copy_wildcards(wilds, CAR(to));
      if (d == @':error')
        return d;
      l = CONS(d, l);
    }
    to = CDR(to);
  }
  if (CONSP(l))
    l = @nreverse(l);
  return l;
}

@(defun translate-pathname (source from to &key ((:case scase) @':local'))
  cl_object wilds, d;
  cl_object host, device, directory, name, type, version;
  cl_object fromcase, tocase;
@
  /* The pathname from which we get the data */
  source = cl_pathname(source);
  /* The mask applied to the source pathname */
  from = cl_pathname(from);
  fromcase = normalize_case(from, @':local');
  /* The pattern which says what the output should look like */
  to = cl_pathname(to);
  tocase = normalize_case(to, @':local');

  if (source->pathname.logical != from->pathname.logical)
    goto error;

  /* Match host names */
  if (cl_string_equal(2, source->pathname.host, from->pathname.host) == ECL_NIL)
    goto error;
  host = to->pathname.host;

  /* Logical pathnames do not have devices. We just overwrite it. */
  device = to->pathname.device;

  /* Match directories */
  wilds = find_list_wilds(source->pathname.directory,
                          from->pathname.directory);
  if (wilds == @':error') goto error;
  if (Null(to->pathname.directory)) {
    /* Missing components are replaced */
    d = translate_list_case(source->pathname.directory, fromcase, tocase);
  } else {
    wilds = translate_list_case(wilds, fromcase, tocase);
    d = copy_list_wildcards(&wilds, to->pathname.directory);
    if (d == @':error') goto error;
    if (wilds != ECL_NIL) goto error2;
  }
  directory = d;

  /* Match name */
  wilds = find_wilds(ECL_NIL, source->pathname.name, from->pathname.name);
  if (wilds == @':error') goto error2;
  if (Null(to->pathname.name)) {
    d = translate_component_case(source->pathname.name, fromcase, tocase);
  } else {
    wilds = translate_list_case(wilds, fromcase, tocase);
    d = copy_wildcards(&wilds, to->pathname.name);
    if (d == @':error') goto error;
    if (wilds != ECL_NIL) goto error2;
  }
  name = d;

  /* Match type */
  wilds = find_wilds(ECL_NIL, source->pathname.type, from->pathname.type);
  if (wilds == @':error') goto error2;
  if (Null(to->pathname.type)) {
    d = translate_component_case(source->pathname.type, fromcase, tocase);
  } else {
    wilds = translate_list_case(wilds, fromcase, tocase);
    d = copy_wildcards(&wilds, to->pathname.type);
    if (d == @':error') goto error;
    if (wilds != ECL_NIL) goto error2;
  }
  type = d;

  /* Match version */
  version = to->pathname.version;
  if (from->pathname.version == @':wild') {
    if (to->pathname.version == @':wild') {
      version = source->pathname.version;
    }
  }
  @(return ecl_make_pathname(host, device, directory, name, type,
                             version, tocase));
 error:
  FEerror("~S is not a specialization of path ~S", 2, source, from);
 error2:
  FEerror("Number of wildcards in ~S do not match  ~S", 2, from, to);
@)

@(defun translate-logical-pathname (source &key)
  cl_object l, pair;
  cl_object pathname;
@
  pathname = cl_pathname(source);
 begin:
  if (!pathname->pathname.logical) {
    @(return pathname);
  }
  l = @si::pathname-translations(1, pathname->pathname.host);
  for(; !ecl_endp(l); l = CDR(l)) {
    pair = CAR(l);
    if (!Null(cl_pathname_match_p(pathname, CAR(pair)))) {
      pathname = cl_translate_pathname(3, pathname, CAR(pair), CADR(pair));
      goto begin;
    }
  }
  FEerror("~S admits no logical pathname translations", 1, pathname);
@)
