From e9133326f799567cce3aaa208e649f42cac218e2 Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Thu, 18 Dec 2003 14:23:37 +0000 Subject: [PATCH] The conditions signaled by MAKE-PATHNAME because of bogus pathname components are now of type FILE-ERROR. --- src/CHANGELOG | 4 ++- src/c/pathname.d | 63 ++++++++++++++++++++--------------------- src/clos/conditions.lsp | 5 +++- 3 files changed, 38 insertions(+), 34 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 78b999180..4cde19cbe 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -1800,7 +1800,9 @@ ECL 0.9d - There is support for the :CASE argument in all pathname functions that require it (Contributed by Julian Stecklina). The function PARSE-NAMESTRING now handles the optional host and - default-pathname arguments properly. + default-pathname arguments properly. MAKE-PATHNAME now signals + conditions of type FILE-ERROR when the components of the pathname + have errors (wrong types, '(:ABSOLUTE :BACK), etc). TODO: ===== diff --git a/src/c/pathname.d b/src/c/pathname.d index e19a6ed70..04519aef7 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -33,14 +33,10 @@ typedef int (*delim_fn)(int); -static void -error_directory(cl_object d) { - FEerror("make-pathname: ~A is not a valid directory", 1, d); -} - static cl_object check_directory(cl_object directory, bool logical) { + /* INV: directory is always a list */ cl_object ptr, item; int i; @@ -52,9 +48,7 @@ check_directory(cl_object directory, bool logical) if (item == @':back') { if (i == 0) return @':error'; - if (i == 1) - return @':error'; - item = nthcdr(i-1, directory); + item = nth(i-1, directory); if (item == @':absolute' || item == @':wild-inferiors') return @':error'; if (i > 2) @@ -62,7 +56,7 @@ check_directory(cl_object directory, bool logical) } if (item == @':up') { if (i == 0) return @':error'; - item = nthcdr(i-1, directory); + item = nth(i-1, directory); if (item == @':absolute' || item == @':wild-inferiors') return @':error'; } else if (item == @':relative' || item == @':absolute') { @@ -99,10 +93,11 @@ make_pathname(cl_object host, cl_object device, cl_object directory, case t_symbol: if (directory == Cnil) break; - if (directory == @':wild') + if (directory == @':wild') { directory = cl_list(2, @':absolute', @':wild-inferiors'); - error_directory(directory); - break; + break; + } + goto ERROR; case t_cons: { cl_object aux = check_directory(cl_copy_list(directory), 1); if (aux != @':error') { @@ -111,8 +106,7 @@ make_pathname(cl_object host, cl_object device, cl_object directory, } } default: - error_directory(directory); - + goto ERROR; } x = cl_alloc_object(t_pathname); if (type_of(host) == t_string) @@ -120,22 +114,30 @@ make_pathname(cl_object host, cl_object device, cl_object directory, else if (host == Cnil) x->pathname.logical = FALSE; else - FEerror("make-pathname: ~A is not a valid hostname", 1, host); + goto ERROR; if (device != Cnil && device != @':unspecific' && !(!x->pathname.logical && type_of(device) == t_string)) - FEerror("make-pathname: ~A is not a valid device name", 1, device); + goto ERROR; if (name != Cnil && name != @':wild' && type_of(name) != t_string) - FEerror("make-pathname: ~A is not a valid file name", 1, name); + goto ERROR; if (type != Cnil && type != @':wild' && type_of(type) != t_string) - FEerror("make-pathname: ~A is not a valid file type", 1, type); - if (version != @':unspecific' && version != @':newest' && version != Cnil) - FEerror("make-pathname: version numbers not allowed", 0); + goto ERROR; + if (version != @':unspecific' && version != @':newest' && version != Cnil) { + ERROR: cl_error(3, @'file-error', @':pathname', + cl_list(13, @'make-pathname', + @':host', host, + @':device', device, + @':directory', directory, + @':name', name, + @':type', type, + @':version', version)); + } x->pathname.host = host; x->pathname.device = device; x->pathname.directory = directory; x->pathname.name = name; x->pathname.type = type; - x->pathname.version = @':unspecific'; + x->pathname.version = version; return(x); } @@ -254,13 +256,15 @@ translate_directory_case(cl_object list, cl_object scase) if (!CONSP(list)) { return translate_pathname_case(list,scase); } else { - cl_object l = cl_copy_list(list); + 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; } } @@ -622,10 +626,8 @@ merge_pathnames(cl_object path, cl_object defaults, cl_object default_version) defaults = cl_pathname(defaults); path = cl_parse_namestring(1, path, Cnil, defaults); - if (Null(path->pathname.host)) + if (Null(host = path->pathname.host)) host = defaults->pathname.host; - else - host = path->pathname.host; if (Null(path->pathname.device)) if (Null(path->pathname.host)) device = defaults->pathname.device; @@ -644,15 +646,12 @@ merge_pathnames(cl_object path, cl_object defaults, cl_object default_version) CDR(path->pathname.directory)); else directory = path->pathname.directory; - if (Null(path->pathname.name)) + if (Null(name = path->pathname.name)) name = defaults->pathname.name; - else - name = path->pathname.name; - if (Null(path->pathname.type)) + if (Null(type = path->pathname.type)) type = defaults->pathname.type; - else - type = path->pathname.type; - version = Cnil; + if (Null(version = path->pathname.version)) + version = defaults->pathname.type; /* In this implementation, version is not considered */ diff --git a/src/clos/conditions.lsp b/src/clos/conditions.lsp index 9524dd6c0..3f1483fa5 100644 --- a/src/clos/conditions.lsp +++ b/src/clos/conditions.lsp @@ -539,7 +539,10 @@ returns with NIL." (stream-error-stream condition))))) (define-condition file-error (error) - ((pathname :INITARG :PATHNAME :READER file-error-pathname))) + ((pathname :INITARG :PATHNAME :READER file-error-pathname)) + (:REPORT (lambda (condition stream) + (format stream "Filesystem error with pathname ~S.~%Either the file cannot be accessed or the pathname is not a valid one." + (file-error-pathname condition))))) (define-condition package-error (error) ((package :INITARG :PACKAGE :READER package-error-package)))