? Makefile
? build
? case.diff
? case2.diff
Index: src/c/load.d
===================================================================
RCS file: /cvsroot/ecls/ecls/src/c/load.d,v
retrieving revision 1.39
diff -u -r1.39 load.d
--- src/c/load.d	1 Dec 2003 11:21:56 -0000	1.39
+++ src/c/load.d	17 Dec 2003 00:41:19 -0000
@@ -143,7 +143,7 @@
 						 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);
 
Index: src/c/pathname.d
===================================================================
RCS file: /cvsroot/ecls/ecls/src/c/pathname.d,v
retrieving revision 1.36
diff -u -r1.36 pathname.d
--- src/c/pathname.d	1 Dec 2003 11:21:56 -0000	1.36
+++ src/c/pathname.d	17 Dec 2003 00:41:19 -0000
@@ -128,7 +128,7 @@
 		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,119 @@
 static int is_dot(int c) { return c == '.'; }
 static int is_null(int c) { return c == '\0'; }
 
+static int is_all_upper(const char *str)
+{
+	if (str != NULL) {
+		int i = 0;
+	
+		while ((str[i] != NULL) && isupper(str[i]))
+			i++;
+
+		return (str[i] == NULL);
+	} else return 1;
+}
+
+static int is_all_lower(const char *str)
+{
+	if (str != NULL) {
+		int i = 0;
+		
+		while ((str[i] != NULL) && islower(str[i]))
+			i++;
+       
+		return (str[i] == NULL);
+	} else return 1;
+}
+
+static void invert_case(cl_object clstr)
+{
+	char *str = clstr->string.self;
+	int i;
+
+	if (str != NULL)
+		for (i=0;str[i]!=NULL;i++) {
+			if (isupper(str[i]))
+				str[i] = tolower(str[i]);
+			else if (islower(str[i]))
+				str[i] = toupper(str[i]);
+		}	
+}
+
+/* 
+ * 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.
+ */
+
+static cl_object translate_common_case(cl_object str)
+{
+	if (type_of(str) != t_string) {
+		return str;    
+	} else if (is_all_upper(str->string.self) || 
+		   is_all_lower(str->string.self)) {
+		cl_object newstr;
+		
+		newstr = make_string_copy(str->string.self);
+
+				/* This really should be conditionalised
+				 * to whatever OS ECL is compiled on
+				 */
+		invert_case(newstr);
+
+		return newstr;
+	} else  {
+		return str;	/* Mixed case goes unchanged */
+	}
+}
+
+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("Got ~S, but wanted either :LOCAL or :COMMON",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 that.
+	 */
+	if (type_of(list)==t_cons) {
+		if (scase == @':common') {
+			/* First element in list is a symbol, don't
+			 * mess with that
+			 */
+			cl_object newhead = CONS(CAR(list),Cnil);
+			cl_object newtail = newhead;
+			cl_object curr;
+
+			for (curr=CDR(list);curr!=Cnil;curr=CDR(curr)) {
+				cl_object object = CAR(curr);
+
+				object = translate_common_case(object);
+
+				CDR(newtail) = CONS(object, Cnil);
+				newtail = CDR(newtail);
+			}
+
+			return newhead;
+		} else {
+			if (scase == @':local')
+				return list;
+			else
+				FEerror("Got ~S, but wanted either :LOCAL or :COMMON",1,scase);
+		}				
+	} else return translate_pathname_case(list,scase);
+}
+
+
 /*
  * Parses a word from string `S' until either:
  *	1) character `DELIM' is found
@@ -814,6 +927,7 @@
 
 @(defun make_pathname (&key (host OBJNULL) (device OBJNULL) (directory OBJNULL)
 			    (name OBJNULL) (type OBJNULL) (version OBJNULL)
+		            ((:case scase) @':local')
 		            defaults
 		       &aux x)
 @
@@ -826,11 +940,16 @@
 			        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 +967,35 @@
 		  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)
Index: src/c/symbols_list.h
===================================================================
RCS file: /cvsroot/ecls/ecls/src/c/symbols_list.h,v
retrieving revision 1.66
diff -u -r1.66 symbols_list.h
--- src/c/symbols_list.h	15 Dec 2003 09:03:38 -0000	1.66
+++ src/c/symbols_list.h	17 Dec 2003 00:41:20 -0000
@@ -645,12 +645,12 @@
 {"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},
@@ -1319,6 +1319,9 @@
 {KEY_ "VERSION", KEYWORD, NULL, -1, OBJNULL},
 {KEY_ "WILD", KEYWORD, NULL, -1, OBJNULL},
 {KEY_ "WILD-INFERIORS", KEYWORD, NULL, -1, OBJNULL},
+
+{KEY_ "COMMON",KEYWORD,NULL,-1,OBJNULL},
+{KEY_ "LOCAL",KEYWORD,NULL,-1,OBJNULL},
 
 {EXT_ "BYTE8", EXT_ORDINARY, NULL, -1, OBJNULL},
 {EXT_ "COMPILER-LET", EXT_FORM, NULL, -1, OBJNULL},
Index: src/h/external.h
===================================================================
RCS file: /cvsroot/ecls/ecls/src/h/external.h,v
retrieving revision 1.112
diff -u -r1.112 external.h
--- src/h/external.h	15 Dec 2003 08:54:10 -0000	1.112
+++ src/h/external.h	17 Dec 2003 00:41:20 -0000
@@ -988,11 +988,11 @@
 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);
