Implement si::mkdir and FEfilesystem_error. Simplify other error handlers.

src/c/all_functions.d

@@ -827,6 +827,7 @@ const struct function_info all_functions[] = {
 	{"STRING-MATCH", siLstring_match, si},
 	{"DIRECTORY", clLdirectory, cl},
 	{"CHDIR", siLchdir, si},
+	{"MKDIR", siLmkdir, si},
 
 	/* unixsys.c */
 

src/c/error.d

@@ -93,31 +93,24 @@ void
 FEerror(char *s, int narg, ...)
 {
 	va_list args;
-	cl_object rest = Cnil, *r = &rest;
-
 	va_start(args, narg);
-	while (narg--)
-	  r = &CDR(*r = CONS(va_arg(args, cl_object), Cnil));
 	funcall(4, @'si::universal-error-handler',
 		Cnil,                    /*  not correctable  */
 		make_constant_string(s),	 /*  condition text  */
-		rest);
+		va_grab_rest_args(narg, args));
+	va_end(args);
 }
 
 cl_object
 CEerror(char *err, int narg, ...)
 {
-	int i = narg;
 	va_list args;
-	cl_object rest = Cnil, *r = &rest;
-
 	va_start(args, narg);
-	while (i--)
-	  r = &CDR(*r = CONS(va_arg(args, cl_object), Cnil));
 	return funcall(4, @'si::universal-error-handler',
 		       Ct,			/*  correctable  */
 		       make_constant_string(err),	/*  continue-format-string  */
-		       rest);
+		       va_grab_rest_args(narg, args));
+	va_end(args);
 }
 
 /***********************
@@ -128,54 +121,39 @@ void
 FEcondition(int narg, cl_object name, ...)
 {
 	va_list args;
-	cl_object rest = Cnil, *r = &rest;
-
 	va_start(args, name);
-	while (--narg) {
-		*r = CONS(va_arg(args, cl_object), Cnil);
-		r = &CDR(*r);
-	}
 	funcall(4, @'si::universal-error-handler',
 		Cnil,                    /*  not correctable  */
 		name,                    /*  condition name  */
-		rest);
+		va_grab_rest_args(--narg, args));
+	va_end(args);
 }
 
 void
 FEprogram_error(const char *s, int narg, ...)
 {
 	va_list args;
-	cl_object rest = Cnil, *r = &rest;
-
 	gc(t_contiguous);
 	va_start(args, narg);
-	while (narg--) {
-		*r = CONS(va_arg(args, cl_object), Cnil);
-		r = &CDR(*r);
-	}
 	funcall(4, @'si::universal-error-handler',
 		Cnil,                    /*  not correctable  */
 		@'si::simple-program-error', /*  condition name  */
 		list(4, @':format-control', make_constant_string(s),
-		     @':format-arguments', rest));
+		     @':format-arguments', va_grab_rest_args(narg, args)));
+	va_end(args);
 }
 
 void
 FEcontrol_error(const char *s, int narg, ...)
 {
 	va_list args;
-	cl_object rest = Cnil, *r = &rest;
-
 	va_start(args, narg);
-	while (narg--) {
-		*r = CONS(va_arg(args, cl_object), Cnil);
-		r = &CDR(*r);
-	}
 	funcall(4, @'si::universal-error-handler',
 		Cnil,                    /*  not correctable  */
 		@'si::simple-control-error', /*  condition name  */
 		list(4, @':format-control', make_constant_string(s),
-		     @':format-arguments', rest));
+		     @':format-arguments', va_grab_rest_args(narg, args)));
+	va_end(args);
 }
 
 void
@@ -299,31 +277,19 @@ not_a_variable(cl_object obj)
  ************************************/
 
 @(defun error (eformat &rest args)
-	int i;
-	cl_object rest = Cnil, *r = &rest;
 @
-	for (i=narg-1; i; i--) {
-	  *r = CONS(va_arg(args, cl_object), Cnil);
-	  r = &CDR(*r);
-	}
 	funcall(4, @'si::universal-error-handler',
 		Cnil,
 		eformat,
-		rest);
+		va_grab_rest_args(narg-1, args));
 @)
 
 @(defun cerror (cformat eformat &rest args)
-	int i;
-	cl_object rest = Cnil, *r = &rest;
 @
-	for (i=narg-2; i; i--) {
-	  *r = CONS(va_arg(args, cl_object), Cnil);
-	  r = &CDR(*r);
-	}
 	return(funcall(4, @'si::universal-error-handler',
 		       cformat,
 		       eformat,
-		       rest));
+		       va_grab_rest_args(narg-2, args)));
 @)
 
 void

src/c/main.d

@@ -133,8 +133,7 @@ cl_boot(int argc, char **argv)
 @)
 
 @(defun si::getenv (var)
-	char name[256], *value;
-	cl_index i;
+	const char *value;
 @
 	assert_type_string(var);
 	value = getenv(var->string.self);

src/c/unixfsys.d

@@ -14,6 +14,7 @@
     See file '../Copyright' for full details.
 */
 
+#include <errno.h>
 #include <string.h>
 #include <unistd.h>
 #include <sys/types.h>
@@ -23,11 +24,55 @@
 #ifdef BSD
 #include <dirent.h>
 #else
-#include "<sys/dir.h>"
+#include <sys/dir.h>
 #endif
 
 cl_object @':list-all';
 
+/*
+ * Interprets an error code from the C library according to the POSIX
+ * standard, and produces a suitable error message by combining the user
+ * supplied format with an explanation of the cause of the error.
+ */
+void
+FEfilesystem_error(const char *msg, int narg, ...)
+{
+	va_list args;
+	cl_object rest;
+	const char *extra_msg;
+
+	va_start(args, narg);
+	rest = va_grab_rest_args(narg, args);
+	va_end(args);
+
+	switch (errno) {
+	case EPERM:
+	case EACCES:
+	case EROFS:
+		extra_msg = "Insufficient permissions";
+		break;
+	case EEXIST:
+		extra_msg = "Already exists";
+		break;
+	case ENAMETOOLONG:
+		extra_msg = "File or directory name too long";
+		break;
+	case ENOENT:
+	case ENOTDIR:
+	case ELOOP:
+		extra_msg = "Invalid or not existent path";
+		break;
+	case ENOSPC:
+		extra_msg = "Not enough space or quota exceeded";
+		break;
+	default:
+		extra_msg = "Uknown reason";
+		break;
+	}
+	FEerror("~?~%Explanation: ~A.", 3, make_constant_string(msg), rest,
+		make_constant_string(extra_msg));
+}
+
 /*
  * string_to_pathanme, to be used when s is a real pathname
  */
@@ -98,8 +143,8 @@ get_file_system_type(const char *namestring) {
  */
 static cl_object
 error_no_dir(cl_object pathname) {
-	FEerror("truedirectory: does not exist or cannot be accessed",1,pathname);
-	return OBJNULL;
+	FEfilesystem_error("truedirectory: ~S cannot be accessed", 1, pathname);
+	return Cnil;
 }
 
 cl_object
@@ -225,7 +270,8 @@ file_len(FILE *fp)
 	filename = coerce_to_filename(oldn);
 	newfilename = coerce_to_filename(newn);
 	if (rename(filename->string.self, newfilename->string.self) < 0)
-		FEerror("Cannot rename the file ~S to ~S.", 2, oldn, newn);
+		FEfilesystem_error("Cannot rename the file ~S to ~S.", 2,
+				   oldn, newn);
 	new_truename = truename(newn);
 	@(return newn old_truename new_truename)
 @)
@@ -236,7 +282,7 @@ file_len(FILE *fp)
 	/* INV: coerce_to_filename() checks types */
 	filename = coerce_to_filename(file);
 	if (unlink(filename->string.self) < 0)
-		FEerror("Cannot delete the file ~S.", 1, file);
+		FEfilesystem_error("Cannot delete the file ~S.", 1, file);
 	@(return Ct)
 @)
 
@@ -270,7 +316,8 @@ file_len(FILE *fp)
 	/* INV: coerce_to_filename() checks types */
 	filename = coerce_to_filename(file);
 	if (stat(filename->string.self, &filestatus) < 0)
-		FEerror("Cannot get the file status of ~S.", 1, file);
+		FEfilesystem_error("Cannot get the file status of ~S.", 1,
+				   file);
 	pwent = getpwuid(filestatus.st_uid);
 	@(return make_string_copy(pwent->pw_name))
 @)
@@ -433,12 +480,12 @@ actual_directory(cl_object namestring, cl_object mask, bool all)
 
 	if (chdir(namestring->string.self) < 0) {
 	  chdir(saved_dir->string.self);
-	  FEerror("directory: cannot access ~A",1,namestring);
+	  FEfilesystem_error("directory: cannot access ~A", 1, namestring);
 	}
 	dir = opendir(".");
 	if (dir == NULL) {
 	  chdir(saved_dir->string.self);
-	  FEerror("Can't open the directory ~S.", 1, dir);
+	  FEfilesystem_error("Can't open the directory ~S.", 1, dir);
 	}
 
 	while ((entry = readdir(dir))) {
@@ -462,12 +509,12 @@ actual_directory(cl_object namestring, cl_object mask, bool all)
 
 	if (chdir(namestring->string.self) < 0) {
 	  chdir(saved_dir->string.self);
-	  FEerror("directory: cannot access ~A",1,namestring);
+	  FEfilesystem_error("directory: cannot access ~A",1,namestring);
 	}
 	fp = fopen(".", OPEN_R);
 	if (fp == NULL) {
 	  chdir(saved_dir->string.self);
-	  FEerror("Can't open the directory ~S.", 1, dir);
+	  FEfilesystem_error("Can't open the directory ~S.", 1, dir);
 	}
 
 	setbuf(fp, iobuffer);
@@ -549,12 +596,25 @@ actual_directory(cl_object namestring, cl_object mask, bool all)
 	/* INV: coerce_to_filename() checks types */
 	filename = coerce_to_filename(directory);
 	previous = current_dir();
-	if (chdir(filename->string.self) < 0)
-		FEerror("Can't change the current directory to ~S.",
-			1, directory);
+	if (chdir(filename->string.self) < 0) {
+		FEfilesystem_error("Can't change the current directory to ~S",
+				   1, filename);
+	}
 	@(return previous)
 @)
 
+@(defun si::mkdir (directory)
+	cl_object filename;
+@
+	/* INV: coerce_to_filename() checks types */
+	filename = coerce_to_filename(directory);
+	if (mkdir(filename->string.self, 0777) < 0) {
+		FEfilesystem_error("Could not create directory ~S", 1,
+				   filename);
+	}
+	@(return filename)
+@)
+
 #ifdef sun4sol2
 /* These functions can't be used with static linking on Solaris */
 struct passwd *

src/h/external.h

@@ -907,6 +907,7 @@ extern FILE *backup_fopen(const char *filename, const char *option);
 extern int file_len(FILE *fp);
 extern cl_object homedir_pathname(cl_object user);
 extern void init_unixfsys(void);
+extern void FEfilesystem_error(const char *msg, int narg, ...);
 
 
 /* unixint.c */

src/h/lisp_external.h

@@ -1025,6 +1025,7 @@ extern cl_object clLfile_write_date _ARGS((int narg, cl_object file));
 extern cl_object clLfile_author _ARGS((int narg, cl_object file));
 extern cl_object clLuser_homedir_pathname _ARGS((int narg, ...));
 extern cl_object siLchdir _ARGS((int narg, cl_object directory));
+extern cl_object siLmkdir _ARGS((int narg, cl_object directory));
 extern cl_object siLstring_match _ARGS((int narg, cl_object string, cl_object pattern));
 extern cl_object clLdirectory _ARGS((int narg, ...));