From 8bba2eadcfd12776f740e1a87bfa8390d97b3fbf Mon Sep 17 00:00:00 2001 From: jjgarcia Date: Wed, 17 Dec 2003 10:28:26 +0000 Subject: [PATCH] Support for :CASE keyword argument in most pathname functions (Contributed by Julian Stecklina). COMPILE-FILE now handles relative pathnames. --- src/CHANGELOG | 6 ++ src/c/load.d | 2 +- src/c/pathname.d | 156 +++++++++++++++++++++++++++++++++---------- src/c/symbols_list.h | 12 ++-- src/cmp/cmptop.lsp | 8 ++- src/h/external.h | 10 +-- 6 files changed, 147 insertions(+), 47 deletions(-) diff --git a/src/CHANGELOG b/src/CHANGELOG index 2e08abd6b..833ee5954 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -1738,6 +1738,9 @@ ECL 0.9d - SIGNUM now accepts complex arguments. + - COMPILE-FILE now handles files with relative pathnames (like + "foo/faa.lsp"). + * Documentation: - New manual page documents the scripting facilities of ECL @@ -1794,6 +1797,9 @@ ECL 0.9d CHANGE-CLASS, UPDATE-INSTANCE-FOR-{REDEFINED,NEW}-CLASS, and MAKE-INSTANCES-OBSOLETE. + - There is support for the :CASE argument in all pathname functions + that require it (Contributed by Julian Stecklina). + TODO: ===== diff --git a/src/c/load.d b/src/c/load.d index 287abcfcc..a304ec40b 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -143,7 +143,7 @@ si_load_binary(cl_object filename, cl_object verbose, cl_object print) prefix, make_simple_string("_")); basename = cl_pathname(filename); - basename = cl_pathname_name(basename); + basename = cl_pathname_name(1,basename); basename = @si::string-concatenate(2, prefix, @string-upcase(1,basename)); block->cblock.entry = ecl_library_symbol(block, basename->string.self); diff --git a/src/c/pathname.d b/src/c/pathname.d index c10e87d1c..868bf6a10 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -128,7 +128,7 @@ make_pathname(cl_object host, cl_object device, cl_object directory, FEerror("make-pathname: ~A is not a valid file name", 1, name); 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 != Cnil) + if (version != @':unspecific' && version != @':newest' && version != Cnil) FEerror("make-pathname: version numbers not allowed", 0); x->pathname.host = host; x->pathname.device = device; @@ -178,6 +178,93 @@ 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'; } +static int +is_all_upper(cl_object s) +{ + int i; + const char *text; + for (i = 0, text = s->string.self; i <= s->string.dim; i++) { + if (!isupper(text[i])) + return 0; + } + return 1; +} + +static int +is_all_lower(cl_object s) +{ + int i; + const char *text; + for (i = 0, text = s->string.self; i <= s->string.dim; i++) { + if (!islower(text[i])) + return 0; + } + return 1; +} + +/* + * 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) +{ + if (type_of(str) != t_string) { + /* Pathnames may contain some other objects, such as symbols, + * numbers, etc, which need not be translated */ + return str; + } else if (is_all_upper(str)) { + /* 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 (is_all_lower(str)) { + /* 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 = 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); + } + } +} + + /* * Parses a word from string `S' until either: * 1) character `DELIM' is found @@ -212,7 +299,7 @@ parse_word(const char *s, delim_fn delim, int flags, cl_index start, 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 == '-'; @@ -770,11 +857,11 @@ L: } start = MAKE_FIXNUM(s + ee); break; - + case t_pathname: y = x; break; - + case t_stream: switch ((enum ecl_smmode)x->stream.mode) { case smm_input: @@ -814,6 +901,7 @@ L: @(defun make_pathname (&key (host OBJNULL) (device OBJNULL) (directory OBJNULL) (name OBJNULL) (type OBJNULL) (version OBJNULL) + ((:case scase) @':local') defaults &aux x) @ @@ -826,11 +914,16 @@ L: Cnil, Cnil, Cnil, Cnil, Cnil); } else defaults = cl_pathname(defaults); - x = make_pathname(host != OBJNULL? host : defaults->pathname.host, - device != OBJNULL? device : defaults->pathname.device, - directory != OBJNULL? directory : defaults->pathname.directory, - name != OBJNULL? name : defaults->pathname.name, - type != OBJNULL? type : defaults->pathname.type, + 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) @) @@ -848,40 +941,35 @@ si_logical_pathname_p(cl_object pname) Ct : Cnil)) } -cl_object -cl_pathname_host(cl_object pname) -{ +@(defun pathname_host (pname &key ((:case scase) @':local')) +@ pname = cl_pathname(pname); - @(return pname->pathname.host) -} + @(return translate_pathname_case(pname->pathname.host,scase)) +@) -cl_object -cl_pathname_device(cl_object pname) -{ +@(defun pathname_device (pname &key ((:case scase) @':local')) +@ pname = cl_pathname(pname); - @(return pname->pathname.device) -} + @(return translate_pathname_case(pname->pathname.device,scase)) +@) -cl_object -cl_pathname_directory(cl_object pname) -{ +@(defun pathname_directory (pname &key ((:case scase) @':local')) +@ pname = cl_pathname(pname); - @(return pname->pathname.directory) -} + @(return translate_directory_case(pname->pathname.directory,scase)) +@) -cl_object -cl_pathname_name(cl_object pname) -{ +@(defun pathname_name(pname &key ((:case scase) @':local')) +@ pname = cl_pathname(pname); - @(return pname->pathname.name) -} + @(return translate_pathname_case(pname->pathname.name,scase)) +@) -cl_object -cl_pathname_type(cl_object pname) -{ +@(defun pathname_type(pname &key ((:case scase) @':local')) +@ pname = cl_pathname(pname); - @(return pname->pathname.type) -} + @(return translate_pathname_case(pname->pathname.type,scase)) +@) cl_object cl_pathname_version(cl_object pname) diff --git a/src/c/symbols_list.h b/src/c/symbols_list.h index e0d0ba387..cd0fbb01f 100644 --- a/src/c/symbols_list.h +++ b/src/c/symbols_list.h @@ -645,12 +645,12 @@ cl_symbols[] = { {"PARSE-INTEGER", CL_ORDINARY, cl_parse_integer, -1, OBJNULL}, {"PARSE-NAMESTRING", CL_ORDINARY, cl_parse_namestring, -1, OBJNULL}, {"PATHNAME", CL_ORDINARY, cl_pathname, 1, OBJNULL}, -{"PATHNAME-DEVICE", CL_ORDINARY, cl_pathname_device, 1, OBJNULL}, -{"PATHNAME-DIRECTORY", CL_ORDINARY, cl_pathname_directory, 1, OBJNULL}, -{"PATHNAME-HOST", CL_ORDINARY, cl_pathname_host, 1, OBJNULL}, +{"PATHNAME-DEVICE", CL_ORDINARY, cl_pathname_device, -1, OBJNULL}, +{"PATHNAME-DIRECTORY", CL_ORDINARY, cl_pathname_directory, -1, OBJNULL}, +{"PATHNAME-HOST", CL_ORDINARY, cl_pathname_host, -1, OBJNULL}, {"PATHNAME-MATCH-P", CL_ORDINARY, cl_pathname_match_p, 2, OBJNULL}, -{"PATHNAME-NAME", CL_ORDINARY, cl_pathname_name, 1, OBJNULL}, -{"PATHNAME-TYPE", CL_ORDINARY, cl_pathname_type, 1, OBJNULL}, +{"PATHNAME-NAME", CL_ORDINARY, cl_pathname_name, -1, OBJNULL}, +{"PATHNAME-TYPE", CL_ORDINARY, cl_pathname_type, -1, OBJNULL}, {"PATHNAME-VERSION", CL_ORDINARY, cl_pathname_version, 1, OBJNULL}, {"PATHNAMEP", CL_ORDINARY, cl_pathnamep, 1, OBJNULL}, {"PEEK-CHAR", CL_ORDINARY, cl_peek_char, -1, OBJNULL}, @@ -1236,6 +1236,7 @@ cl_symbols[] = { {KEY_ "CATCHALL", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "CIRCLE", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "COMPILE-TOPLEVEL", KEYWORD, NULL, -1, OBJNULL}, +{KEY_ "COMMON",KEYWORD,NULL,-1,OBJNULL}, {KEY_ "CONTROL-STRING", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "CREATE", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "DATUM", KEYWORD, NULL, -1, OBJNULL}, @@ -1274,6 +1275,7 @@ cl_symbols[] = { {KEY_ "LEVEL", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "LINK", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "LIST-ALL", KEYWORD, NULL, -1, OBJNULL}, +{KEY_ "LOCAL",KEYWORD,NULL,-1,OBJNULL}, {KEY_ "LOCKABLE", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "LOAD-TOPLEVEL", KEYWORD, NULL, -1, OBJNULL}, {KEY_ "NAME", KEYWORD, NULL, -1, OBJNULL}, diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 2c7a53efa..03e7a51ac 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -85,7 +85,9 @@ ;(let ((*print-level* 3)) (pprint *top-level-forms*)) (setq *top-level-forms* (nreverse *top-level-forms*)) - (wt-nl1 "#include \"" (si::coerce-to-filename h-pathname) "\"") + (wt-nl1 "#include \"" (si::coerce-to-filename (merge-pathnames h-pathname + (si::chdir "./"))) + "\"") (wt-h "#ifdef __cplusplus") (wt-h "extern \"C\" {") (wt-h "#endif") @@ -98,7 +100,9 @@ (*compiler-declared-globals* (make-hash-table)) #+PDE (optimize-space (>= *space* 3))) (unless shared-data - (wt-nl1 "#include \"" (si::coerce-to-filename data-pathname) "\"")) + (wt-nl1 "#include \"" (si::coerce-to-filename (merge-pathnames data-pathname + (si::chdir "./"))) + "\"")) (wt-nl1 "#ifdef __cplusplus") (wt-nl1 "extern \"C\"") (wt-nl1 "#endif") diff --git a/src/h/external.h b/src/h/external.h index ec033f475..24d8557eb 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -988,11 +988,11 @@ extern void unuse_package(cl_object x0, cl_object p); extern cl_object cl_pathname(cl_object name); extern cl_object cl_logical_pathname(cl_object pname); extern cl_object cl_pathnamep(cl_object pname); -extern cl_object cl_pathname_host(cl_object pname); -extern cl_object cl_pathname_device(cl_object pname); -extern cl_object cl_pathname_directory(cl_object pname); -extern cl_object cl_pathname_name(cl_object pname); -extern cl_object cl_pathname_type(cl_object pname); +extern cl_object cl_pathname_host _ARGS((int narg, cl_object pname, ...)); +extern cl_object cl_pathname_device _ARGS((int narg, cl_object pname, ...)); +extern cl_object cl_pathname_directory _ARGS((int narg, cl_object pname, ...)); +extern cl_object cl_pathname_name _ARGS((int narg, cl_object pname, ...)); +extern cl_object cl_pathname_type _ARGS((int narg, cl_object pname, ...)); extern cl_object cl_pathname_version(cl_object pname); extern cl_object cl_namestring(cl_object pname); extern cl_object cl_file_namestring(cl_object pname);