ecl/src/c/pathname.d

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

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

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

/*
	O.S. DEPENDENT

	This file contains those functions that interpret namestrings.
*/

#include <ecl/ecl.h>
#include <string.h>
#include <ctype.h>
#ifdef _MSC_VER
#define MAXPATHLEN 512
#endif
#ifndef MAXPATHLEN
# ifdef PATH_MAX
#   define MAXPATHLEN PATH_MAX
# else
#   error "Either MAXPATHLEN or PATH_MAX should be defined"
# endif
#endif

typedef int (*delim_fn)(int);

static cl_object
ensure_simple_base_string(cl_object s)
{
	switch (type_of(s)) {
#ifdef ECL_UNICODE
	case t_string:
#endif
	case t_base_string:
		return si_copy_to_simple_base_string(s);
	default:
		return s;
	}
}

static cl_object
destructively_check_directory(cl_object directory, bool logical)
{
	/* 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.
	 */
	/* INV: directory is always a list */
	cl_object ptr;
	int i;

	if (CAR(directory) != @':absolute'  && CAR(directory) != @':relative')
		return Cnil;
 BEGIN:
	for (i=0, ptr=directory; !endp(ptr); ptr = CDR(ptr), i++) {
		cl_object item = CAR(ptr);
		if (item == @':back') {
			if (i == 0)
				return @':error';
			item = nth(i-1, directory);
			if (item == @':absolute' || item == @':wild-inferiors')
				return @':error';
			if (i > 2)
				CDR(nthcdr(i-2, directory)) = CDR(ptr);
		} if (item == @':up') {
			if (i == 0)
				return @':error';
			item = 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 (type_of(item) == t_base_string) {
			CAR(ptr) = si_copy_to_simple_base_string(item);
			if (logical)
				continue;
			if (strcmp(item->base_string.self,".")==0) {
				if (i == 0)
					return @':error';
				CDR(nthcdr(i-1, directory)) = CDR(ptr);
			} else if (strcmp(item->base_string.self,"..") == 0) {
				CAR(directory) = @':back';
				goto BEGIN;
			}
		} else if (item != @':wild' && item != @':wild-inferiors') {
			return @':error';
		}
	}
	return directory;
}

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

	p = cl_alloc_object(t_pathname);
	if (type_of(host) == t_base_string)
		p->pathname.logical = logical_hostname_p(host);
	else if (host == Cnil)
		p->pathname.logical = FALSE;
	else {
		x = directory;
		component = @':host';
		goto ERROR;
	}
	if (device != Cnil && device != @':unspecific' &&
	    !(!p->pathname.logical && type_of(device) == t_base_string)) {
		x = device;
		component = @':device';
		goto ERROR;
	}
	if (name != Cnil && name != @':wild' && type_of(name) != t_base_string) {
		x = name;
		component = @':name';
		goto ERROR;
	}
	if (type != Cnil && type != @':wild' && type_of(type) != t_base_string) {
		x = type;
		component = @':type';
		goto ERROR;
	}
	if (version != @':unspecific' && version != @':newest' &&
	    version != @':wild' && version != Cnil && !FIXNUMP(version))
	{
		x = version;
		component = @':version';
	ERROR:	FEerror("~s is not a valid pathname-~a component", 2, x, component);
	}
	switch (type_of(directory)) {
	case t_base_string:
		directory = cl_list(2, @':absolute', directory);
		break;
	case t_symbol:
		if (directory == Cnil)
			break;
		if (directory == @':wild') {
			directory = cl_list(2, @':absolute', @':wild-inferiors');
			break;
		}
		component = @':directory';
		goto ERROR;
	case t_cons:
		directory = cl_copy_list(directory);
		break;
	default:
		x = directory;
		component = @':directory';
		goto ERROR;
	}
	p->pathname.host      = ensure_simple_base_string(host);
	p->pathname.device    = ensure_simple_base_string(device);
	p->pathname.directory = directory;
	p->pathname.name      = ensure_simple_base_string(name);
	p->pathname.type      = ensure_simple_base_string(type);
	p->pathname.version   = ensure_simple_base_string(version);
	if (destructively_check_directory(directory, 1) == @':error') {
		cl_error(3, @'file-error', @':pathname', p);
	}
	return(p);
}

static cl_object
tilde_expand(cl_object directory)
{
	cl_object head, prefix;

	/* INV: pathname is relative */
	if (endp(directory))
		goto RET;
	head = CADR(directory);
	if (type_of(head) != t_base_string)
		goto RET;
	if (head->base_string.fillp == 0 || head->base_string.self[0] != '~')
		goto RET;
	prefix = homedir_pathname(head)->pathname.directory;
	directory = append(prefix, CDDR(directory));
 RET:
	return directory;
}

#define WORD_INCLUDE_DELIM 1
#define WORD_ALLOW_ASTERISK  2
#define WORD_EMPTY_IS_NIL 4
#define WORD_LOGICAL 8
#define WORD_ALLOW_LEADING_DOT 16

static cl_object
make_one(const char *s, cl_index end)
{
	cl_object x = cl_alloc_simple_base_string(end);
	memcpy(x->base_string.self, s, end);
	return(x);
}

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'; }

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

static cl_object
translate_common_case(cl_object str)
{
	int string_case;
	if (type_of(str) != t_base_string) {
		/* Pathnames may contain some other objects, such as symbols,
		 * numbers, etc, which need not be translated */
		return str;
	}
	string_case = ecl_string_case(str);
	if (string_case > 0) { /* ALL_UPPER */
		/* 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 the _local_ case.
		 */
		return cl_string_downcase(1, str);
	} else if (string_case < 0) { /* ALL_LOWER */
		/* 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.
		 */
		return cl_string_upcase(1, str);
	} else {
		/* Mixed case goes unchanged */
		return str;
	}
}

static cl_object
translate_pathname_case(cl_object str, cl_object scase)
{
	if (scase == @':common') {
		return translate_common_case(str);
	} else if (scase == @':local') {
		return str;
	} else {
		FEerror("~S is not a valid pathname case specificer.~S"
			"Only :COMMON or :LOCAL are accepted.", 1, scase);
	}
}

static cl_object
translate_directory_case(cl_object list, cl_object scase)
{
	/* 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_pathname_case(list,scase);
	} else {
		cl_object l;
		list = cl_copy_list(list);
		for (l = cl_copy_list(list); !endp(l); l = CDR(l)) {
			/* It is safe to pass anything to translate_pathname_case,
			 * because it will only transform strings, leaving other
			 * object (such as symbols) unchanged.*/
			CAR(l) = translate_pathname_case(CAR(l), scase);
		}
		return list;
	}
}


/*
 * 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 Cnil when word has no elements
 *	5) A non empty string
 */
static cl_object
parse_word(const char *s, delim_fn delim, int flags, cl_index start,
	   cl_index end, cl_index *end_of_word)
{
	cl_index i, j;
	bool wild_inferiors = FALSE;

	i = j = start;
	if ((flags & WORD_ALLOW_LEADING_DOT) && (i < end) && delim(s[i]))
		i++;
	for (; i < end && !delim(s[i]); i++) {
		char c = s[i];
		bool valid_char;
		if (c == '*') {
			if (!(flags & WORD_ALLOW_ASTERISK))
				valid_char = FALSE; /* Asterisks not allowed in this word */
			else {
				wild_inferiors = (i > start && s[i-1] == '*');
				valid_char = TRUE; /* single "*" */
			}
		}
#if 0
		else if (flags & WORD_LOGICAL)
			valid_char = is_upper(c) || is_digit(c) || c == '-';
#endif
		else
			valid_char = c != 0;
		if (!valid_char) {
			*end_of_word = start;
			return @':error';
		}
	}
	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 Cnil;
		}
	}
	s += j;
	switch(i-j) {
	case 0:
		if (flags & WORD_EMPTY_IS_NIL)
			return Cnil;
		return cl_core.null_string;
	case 1:
		if (s[0] == '*')
			return @':wild';
		break;
	case 2:
		if (s[0] == '*' && s[1] == '*')
			return @':wild-inferiors';
		if (!(flags & WORD_LOGICAL) && s[0] == '.' && s[1] == '.')
			return @':up';
		break;
	default:
		if (wild_inferiors)	/* '**' surrounded by other characters */
			return @':error';
	}
	return make_one(s, i-j);
}

/*
 * 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(const char *s, int flags, cl_index start, cl_index end,
		  cl_index *end_of_dir)
{
	cl_index i, j;
	cl_object path = Cnil;
	cl_object *plast = &path;
	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 == Cnil)
			break;
		if (part == cl_core.null_string) {  /* "/", ";" */
			if (j != start) {
				if (flags & WORD_LOGICAL)
					return @':error';
				continue;
			}
			part = (flags & WORD_LOGICAL) ? @':relative' : @':absolute';
		}
		*end_of_dir = i;
		plast = &CDR(*plast = CONS(part, Cnil));
	}
	return path;
}

bool
logical_hostname_p(cl_object host)
{
	if (type_of(host) != t_base_string)
		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
parse_namestring(const char *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;
		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 Cnil as output.
	 */
	host = parse_word(s, is_colon, WORD_LOGICAL | WORD_INCLUDE_DELIM,
			  start, end, ep);
	if (default_host != Cnil) {
		if (host == Cnil || host == @':error')
			host = default_host;
	}
	if (!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 (CAR(path) != @':relative' && CAR(path) != @':absolute')
			path = CONS(@':absolute', path);
		path = destructively_check_directory(path, TRUE);
	}
	if (path == @':error')
		return Cnil;
	name = parse_word(s, is_dot, WORD_LOGICAL | WORD_ALLOW_ASTERISK |
			  WORD_EMPTY_IS_NIL, *ep, end, ep);
	if (name == @':error')
		return Cnil;
	type = Cnil;
	version = Cnil;
	if (*ep == start || 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 Cnil;
	if (*ep == start || 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 Cnil;
	} else if (SYMBOLP(aux)) {
		version = aux;
	} else {
		version = cl_parse_integer(3, aux, @':junk-allowed', Ct);
		if (cl_integerp(version) != Cnil && number_plusp(version) &&
		    fix(VALUES(1)) == aux->base_string.fillp)
			;
		else if (cl_string_equal(2, aux, @':newest') != Cnil)
			version = @':newest';
		else
			return Cnil;
	}
	goto make_it;
 physical:
	/*
	 * Physical pathname format:
	 *	[device:][[//hostname]/][directory-component/]*[pathname-name][.pathname-type]
	 */
	logical = FALSE;
	device = parse_word(s, is_colon, WORD_INCLUDE_DELIM|WORD_EMPTY_IS_NIL,
			    start, end, ep);
	if (device == @':error')
		device = Cnil;
	else if (device != Cnil) {
		if (type_of(device) != t_base_string)
			return Cnil;
		if (strcmp(device->base_string.self, "file") == 0)
			device = Cnil;
	}
	start = *ep;
	if (start <= end - 2 && is_slash(s[start]) && is_slash(s[start+1])) {
		host = parse_word(s, is_slash, WORD_EMPTY_IS_NIL,
				  start+2, end, ep);
		if (host != Cnil) {
			start = *ep;
			if (is_slash(s[--start])) *ep = start;
		}
	} else
		host = Cnil;
	if (host == @':error')
		host = Cnil;
	else if (host != Cnil) {
		if (type_of(host) != t_base_string)
			return Cnil;
	}
	path = parse_directories(s, 0, *ep, end, ep);
	if (CONSP(path)) {
		if (CAR(path) != @':relative' && CAR(path) != @':absolute')
			path = CONS(@':relative', path);
		path = tilde_expand(path);
		path = destructively_check_directory(path, FALSE);
	}
	if (path == @':error')
		return Cnil;
	name = parse_word(s, is_dot, WORD_ALLOW_LEADING_DOT |
			  WORD_ALLOW_ASTERISK | WORD_EMPTY_IS_NIL,
			  *ep, end, ep);
	if (name == @':error')
		return Cnil;
	if (*ep == start || s[*ep-1] != '.') {
		type = Cnil;
	} else {
		type = parse_word(s, is_null, WORD_ALLOW_ASTERISK, *ep, end, ep);
		if (type == @':error')
			return Cnil;
	}
	if (name != Cnil || type != Cnil)
		version = @':newest';
	else
		version = Cnil;
 make_it:
	if (*ep >= end) *ep = end;
	path = make_pathname(host, device, path, name, type, version);
	path->pathname.logical = logical;
	return 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 = symbol_value(@'*default-pathname-defaults*');
	if (type_of(path) == t_base_string) {
		/* Avoids infinite loop by giving a third argument to
		 * parse-namestring */
		path = cl_parse_namestring(3, path, Cnil, Cnil);
	} else {
		path = cl_pathname(path);
	}
	@(return path)
}

cl_object
cl_pathname(cl_object x)
{
L:
	switch (type_of(x)) {
	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 smm_input:
		case smm_output:
		case smm_probe:
		case smm_io:
			x = x->stream.object1;
			/*
				The file was stored in stream.object1.
				See open.
			*/
			goto L;

		case smm_synonym:
			x = symbol_value(x->stream.object0);
			goto L;
		default:
			;/* Fall through to error message */
		}
	default:
		FEwrong_type_argument(cl_list(4, @'or', @'file-stream',
					      @'string', @'pathname'),
				      x);
	}
	@(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',
			 make_constant_base_string("~S cannot be coerced to a logical pathname."),
			 @':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 == Cnil || component == @':host') {
		if (pathname->pathname.host == @':wild')
			@(return Ct);
		checked = 1;
	}
	if (component == Cnil || component == @':device') {
		if (pathname->pathname.device == @':wild')
			@(return Ct);
		checked = 1;
	}
	if (component == Cnil || component == @':version') {
		if (pathname->pathname.version == @':wild')
			@(return Ct);
		checked = 1;
	}
	if (component == Cnil || component == @':name') {
		cl_object name = pathname->pathname.name;
		if (name != Cnil &&
		    (name == @':wild' || (!SYMBOLP(name) && member_char('*', name))))
			@(return Ct);
		checked = 1;
	}
	if (component == Cnil || component == @':type') {
		cl_object name = pathname->pathname.type;
		if (name != Cnil &&
		    (name == @':wild' || (!SYMBOLP(name) && member_char('*', name))))
			@(return Ct);
		checked = 1;
	}
	if (component == Cnil || component == @':directory') {
		cl_object list = pathname->pathname.directory;
		checked = 1;
		while (list != Cnil) {
			cl_object name = CAR(list);
			if (name != Cnil &&
			    (name == @':wild' || name == @':wild-inferiors' ||
			     (!SYMBOLP(name) && member_char('*', name))))
			{
				@(return Ct)
			}
			list = CDR(list);
		}
	}
	if (checked == 0) {
		FEerror("~A is not a valid pathname component", 1, component);
	}
	@(return Cnil)
@)

/*
 * 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(mingw32) && !defined(_MSC_VER)
	if (pathname->pathname.device != Cnil)
		FEerror("Device ~S not yet supported.", 1,
			pathname->pathname.device);
	if (pathname->pathname.host != Cnil)
		FEerror("Access to remote files not yet supported.", 0);
#endif
#endif
	if (pathname->pathname.directory == Cnil ||
	    CAR(pathname->pathname.directory) == @':relative') {
		pathname = cl_merge_pathnames(2, pathname,
					      si_getcwd());

	}
	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) != Cnil)
		cl_error(3, @'file-error', @':pathname', pathname_orig);
	namestring = cl_namestring(pathname);
	if (namestring == Cnil) {
		FEerror("Pathname ~A does not have a physical namestring",
			1, pathname_orig);
	}
	if (namestring->base_string.fillp >= MAXPATHLEN - 16)
		FEerror("Too long filename: ~S.", 1, namestring);
	return namestring;
}

#define default_device(host) Cnil

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

	defaults = cl_pathname(defaults);
	path = cl_parse_namestring(1, path, Cnil, defaults);
	if (Null(host = path->pathname.host))
		host = defaults->pathname.host;
	if (Null(path->pathname.device))
		if (Null(path->pathname.host))
			device = defaults->pathname.device;
		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 = defaults->pathname.directory;
	else if (CAR(path->pathname.directory) == @':absolute')
		directory = path->pathname.directory;
	else if (!Null(defaults->pathname.directory))
		directory = append(defaults->pathname.directory,
				   CDR(path->pathname.directory));
	else
		directory = path->pathname.directory;
	if (Null(name = path->pathname.name))
		name = defaults->pathname.name;
	if (Null(type = path->pathname.type))
		type = defaults->pathname.type;
	version = path->pathname.version;
	if (Null(path->pathname.name)) {
		if (Null(version))
			version = defaults->pathname.version;
	}
	if (Null(version))
		version = default_version;
	/*
		In this implementation, version is not considered
	*/
	defaults = make_pathname(host, device, directory, name, type, version);
	return defaults;
}

static void
push_c_string(cl_object buffer, const char *s, cl_index length)
{
	for (; length; length--, s++) {
		ecl_string_push_extend(buffer, *s);
	}
}

static void
push_string(cl_object buffer, cl_object string)
{
	string = cl_string(string);
	push_c_string(buffer, string->base_string.self, string->base_string.fillp);
}

/*
	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 truncate_if_unreadable)
{
	bool logical;
	cl_object l, y;
	cl_object buffer, host;

	x = cl_pathname(x);

	/* INV: Pathnames can only be created by mergin, parsing namestrings
	 * or using 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);
	logical = x->pathname.logical;
	host = x->pathname.host;
	if (logical) {
		if ((y = x->pathname.device) != @':unspecific' &&
		    truncate_if_unreadable)
			return Cnil;
		if (host != Cnil) {
			si_do_write_sequence(host, buffer, MAKE_FIXNUM(0), Cnil);
			writestr_stream(":", buffer);
		}
	} else {
		if ((y = x->pathname.device) != Cnil) {
			si_do_write_sequence(y, buffer, MAKE_FIXNUM(0), Cnil);
			writestr_stream(":", buffer);
		}
		if (host != Cnil) {
			if (y == Cnil) {
				writestr_stream("file:", buffer);
			}
			writestr_stream("//", buffer);
			si_do_write_sequence(host, buffer, MAKE_FIXNUM(0), Cnil);
		}
	}
	l = x->pathname.directory;
	if (endp(l))
		goto NO_DIRECTORY;
	y = CAR(l);
	if (y == @':relative') {
		if (logical)
			ecl_write_char(';', buffer);
	} else {
		if (!logical)
			ecl_write_char(DIR_SEPARATOR, buffer);
	}
	for (l = CDR(l); !endp(l); l = CDR(l)) {
		y = 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, MAKE_FIXNUM(0), Cnil);
		} else {
			/* Directory :back has no namestring representation */
			return Cnil;
		}
		ecl_write_char(logical? ';' : DIR_SEPARATOR, buffer);
	}
NO_DIRECTORY:
	y = x->pathname.name;
	if (y != Cnil) {
		if (y == @':wild') {
			writestr_stream("*", buffer);
		} else {
			si_do_write_sequence(y, buffer, MAKE_FIXNUM(0), Cnil);
		}
	}
	y = x->pathname.type;
	if (y != Cnil) {
		if (y == @':wild') {
			writestr_stream(".*", buffer);
		} else {
			writestr_stream(".", buffer);
			si_do_write_sequence(y, buffer, MAKE_FIXNUM(0), Cnil);
		}
	}
	y = x->pathname.version;
	if (logical) {
		if (y != Cnil) {
			writestr_stream(".", buffer);
			if (y == @':wild') {
				writestr_stream("*", buffer);
			} else if (y == @':newest') {
				si_do_write_sequence(y->symbol.name, buffer,
						     MAKE_FIXNUM(0), Cnil);
			} else {
				/* Since the printer is not reentrant,
				 * we cannot use cl_write and friends.
				 */
				int n = fix(y), i;
				char b[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 != Cnil)
				return Cnil;
		} else if (y != @':newest') {
			/* Filenames have an implicit version :newest */
			return Cnil;
		}
	}
	return cl_get_output_stream_string(buffer);
}

cl_object
cl_namestring(cl_object x)
{
	@(return ecl_namestring(x, 1))
}

@(defun parse_namestring (thing
	&o host (defaults si_default_pathname_defaults())
	&k (start MAKE_FIXNUM(0)) end junk_allowed
	&a output)
	cl_index s, e, ee;
@
	if (host != Cnil) {
		host = cl_string(host);
	}
	if (type_of(thing) != t_base_string) {
		output = cl_pathname(thing);
	} else {
		cl_object default_host = host;
		if (default_host == Cnil && defaults != Cnil) {
			defaults = cl_pathname(defaults);
			default_host = defaults->pathname.host;
		}
		get_string_start_end(thing, start, end, &s, &e);
		output = parse_namestring(thing->base_string.self, s, e - s, &ee,
					  default_host);
		start = MAKE_FIXNUM(s + ee);
		if (output == Cnil || ee != e - s) {
			if (Null(junk_allowed)) {
				FEparse_error("Cannot parse the namestring ~S~%"
					      "from ~S to ~S.", Cnil,
					      3, thing, start, end);
			}
			goto OUTPUT;
		}
	}
	if (host != Cnil && !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 merge_pathnames(path, defaults, default_version))
@)

@(defun make_pathname (&key (host OBJNULL) (device OBJNULL) (directory OBJNULL)
			    (name OBJNULL) (type OBJNULL) (version OBJNULL)
		            ((:case scase) @':local')
		            defaults
		       &aux x)
@
	if (Null(defaults)) {
		defaults = si_default_pathname_defaults();
		defaults = make_pathname(defaults->pathname.host,
					 Cnil, Cnil, Cnil, Cnil, Cnil);
	} else {
		defaults = cl_pathname(defaults);
	}
	x = make_pathname(host != OBJNULL? translate_pathname_case(host,scase)
			                 : defaults->pathname.host,
			  device != OBJNULL? translate_pathname_case(device,scase)
			                   : defaults->pathname.device,
			  directory != OBJNULL? translate_directory_case(directory,scase)
			                      : defaults->pathname.directory,
			  name != OBJNULL? translate_pathname_case(name,scase)
			                      : defaults->pathname.name,
			  type != OBJNULL? translate_pathname_case(type,scase)
                                              : defaults->pathname.type,
			  version != OBJNULL? version : defaults->pathname.version);
	@(return x)
@)

cl_object
cl_pathnamep(cl_object pname)
{
	@(return ((type_of(pname) == t_pathname)? Ct : Cnil))
}

cl_object
si_logical_pathname_p(cl_object pname)
{
	@(return ((type_of(pname) == t_pathname && pname->pathname.logical)?
		  Ct : Cnil))
}

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

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

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

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

@(defun pathname_type(pname &key ((:case scase) @':local'))
@
	pname = cl_pathname(pname);
        @(return translate_pathname_case(pname->pathname.type,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(make_pathname(Cnil, Cnil, Cnil,
					      pname->pathname.name,
					      pname->pathname.type,
					      pname->pathname.version),
				1))
}

cl_object
cl_directory_namestring(cl_object pname)
{
	pname = cl_pathname(pname);
	@(return ecl_namestring(make_pathname(Cnil, Cnil,
					      pname->pathname.directory,
					      Cnil, Cnil, Cnil),
				1))
}

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) (equalp(p1->pathname.el, p2->pathname.el)? Cnil : 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 = CONS(@':relative', Cnil);
	} else if (Null(defaultdir)) {
		/* The defaults pathname does not have a directory. */
	} else if (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_index begin;
		cl_object dir_begin = funcall(5, @'mismatch', pathdir, defaultdir,
					      @':test', @'equal');
		if (dir_begin != Cnil && (dir_begin == cl_length(defaultdir))) {
			pathdir = funcall(3, @'subseq', pathdir, dir_begin);
			pathdir = CONS(@':relative', pathdir);
		}
	}
	fname = EN_MATCH(path, defaults, name);
	if (fname == Cnil) fname = path->pathname.name;
	/* Create a path with all elements that do not match the default */
	newpath
	= make_pathname(EN_MATCH(path, defaults, host),
			EN_MATCH(path, defaults, device),
			pathdir, fname,
			EN_MATCH(path, defaults, type),
			EN_MATCH(path, defaults, version));
	newpath->pathname.logical = path->pathname.logical;
	@(return ecl_namestring(newpath, 1))
@)
#undef EN_MATCH

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

static bool path_item_match(cl_object a, cl_object mask);

static bool
do_path_item_match(const char *s, const char *p) {
	const char *next;
	while (*s) {
	  if (*p == '*') {
	    /* Match any group of characters */
	    next = p+1;
	    while (*s && *s != *next) s++;
	    if (do_path_item_match(s,next))
	      return TRUE;
	    /* starts back from the '*' */
	    if (!*s)
	      return FALSE;
	    s++;
	  } else if (*s != *p)
	    return FALSE;
	  else
	    s++, p++;
	}
	return (*p == 0);
}

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 (type_of(a) != t_base_string || mask == Cnil)
		return (a == mask);
	if (type_of(mask) != t_base_string)
		FEerror("~S is not supported as mask for pathname-match-p", 1, mask);
	return do_path_item_match(a->base_string.self, mask->base_string.self);
}

static bool
path_list_match(cl_object a, cl_object mask) {
	cl_object item_mask;
	while (!endp(mask)) {
		item_mask = CAR(mask);
		mask = CDR(mask);
		if (item_mask == @':wild-inferiors') {
			if (endp(mask))
				return TRUE;
			while (!endp(a)) {
				if (path_list_match(a, mask))
					return TRUE;
				a = CDR(a);
			}
			return FALSE;
		} else if (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 (!endp(a))
		return FALSE;
	return TRUE;
}

cl_object
cl_pathname_match_p(cl_object path, cl_object mask)
{
	cl_object output = Cnil;
	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 (!Null(mask->pathname.name) &&
	    !path_item_match(path->pathname.name, mask->pathname.name))
		goto OUTPUT;
	if (!Null(mask->pathname.type) &&
	    !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 = Ct;
 OUTPUT:
	@(return output)
}

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

static cl_object
coerce_to_from_pathname(cl_object x, cl_object host)
{
	switch (type_of(x)) {
	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_length, length;
	cl_object pair, l;
@
	/* Check that host is a valid host name */
	assert_type_base_string(host);
	length = host->base_string.fillp;
	parse_word(host->base_string.self, is_null, WORD_LOGICAL, 0, length,
		   &parsed_length);
	if (parsed_length < host->base_string.fillp)
		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 == Cnil)? Cnil : CADR(pair)))

	/* Set the new translation list */
	assert_type_list(set);
	if (pair == Cnil) {
		pair = CONS(host, CONS(Cnil, Cnil));
		cl_core.pathname_translations = CONS(pair, cl_core.pathname_translations);
	}
	for (l = set, set = Cnil; !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, Cnil)), set);
	}
	CADR(pair) = @nreverse(set);
	@(return set)
@)

static cl_object
find_wilds(cl_object l, cl_object source_item, cl_object match)
{
	const char *a, *b;
	cl_index i, j, k, ia, ib;

	if (match == @':wild')
		return CONS(source_item, Cnil);
	if (type_of(match) != t_base_string || type_of(source_item) != t_base_string) {
		if (match != source_item)
			return @':error';
		return l;
	}
	a  = source_item->base_string.self;
	ia = source_item->base_string.fillp;
	b  = match->base_string.self;
	ib = match->base_string.fillp;
	for(i = j = 0; i < ia && j < ib; ) {
		if (b[j] == '*') {
			for (j++, k = i; k < ia && a[k] != b[j]; k++)
				;
			l = CONS(make_one(&a[i], k-i), l);
			i = k;
			continue;
		}
		if (a[i] != b[j])
			return @':error';
		i++, j++;
	}
	if (i < ia || j < ib)
		return @':error';
	return l;
}

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

	while (!endp(mask)) {
		cl_object item_mask = CAR(mask);
		mask = CDR(mask);
		if (item_mask == @':wild-inferiors') {
			l2 = Cnil;
			while (!path_list_match(a, mask)) {
				if (endp(a))
					return @':error';
				l2 = CONS(CAR(a),l2);
				a = CDR(a);
			}
			l = CONS(l2, l);
		} else if (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)
{
	char *s;
	cl_index i, l, j;
	bool new_string;
	cl_object wilds = *wilds_list;

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

	new_string = FALSE;
	s = pattern->base_string.self;
	l = pattern->base_string.fillp;
	cl_env.token->base_string.fillp = 0;

	for (j = i = 0; i < l; ) {
		if (s[i] != '*') {
			i++;
			continue;
		}
		if (i != j)
			push_c_string(cl_env.token, &s[j], i-j);
		new_string = TRUE;
		if (endp(wilds))
			return @':error';
		push_string(cl_env.token, CAR(wilds));
		wilds = CDR(wilds);
		j = i++;
	}
	/* Only create a new string when needed */
	if (new_string)
		pattern = si_copy_to_simple_base_string(cl_env.token);
	*wilds_list = wilds;
	return pattern;
}

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

	while (!endp(to)) {
		cl_object d, mask = CAR(to);
		if (mask == @':wild-inferiors') {
			cl_object list = *wilds;
			if (endp(list))
				return @':error';
			else {
				cl_object dirlist = CAR(list);
				if (CONSP(dirlist))
					l = 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)
	cl_object wilds, out, d;
@
	/* The pathname from which we get the data */
	source = cl_pathname(source);
	/* The mask applied to the source pathname */
	from = cl_pathname(from);
	/* The pattern which says what the output should look like */
	to = cl_pathname(to);

	if (source->pathname.logical != from->pathname.logical)
		goto error;
	out = cl_alloc_object(t_pathname);
	out->pathname.logical = to->pathname.logical;

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

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

	/* Match directories */
	wilds = find_list_wilds(source->pathname.directory,
				from->pathname.directory);
	if (wilds == @':error')	goto error;
	d = copy_list_wildcards(&wilds, to->pathname.directory);
	if (d == @':error') goto error;
	if (wilds != Cnil) goto error2;
	out->pathname.directory = d;

	/* Match name */
	wilds = find_wilds(Cnil, source->pathname.name, from->pathname.name);
	if (wilds == @':error') goto error2;
	d = copy_wildcards(&wilds, to->pathname.name);
	if (d == @':error') goto error;
	if (wilds != Cnil) goto error2;
	out->pathname.name = d;

	/* Match type */
	wilds = find_wilds(Cnil, source->pathname.type, from->pathname.type);
	if (wilds == @':error') goto error2;
	d = copy_wildcards(&wilds, to->pathname.type);
	if (d == @':error') goto error;
	if (wilds != Cnil) goto error2;
	out->pathname.type = d;

	/* Match version */
	out->pathname.version = to->pathname.version;
	if (from->pathname.version == @':wild') {
		if (to->pathname.version == @':wild') {
			out->pathname.version = source->pathname.version;
		}
	}
	return out;

 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(; !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);
@)