@@@ more wip

[runlisp] / dump-runlisp-image.c

diff --git a/dump-runlisp-image.c b/dump-runlisp-image.c
index 1c6cb557464f7a4b2a93266f866864910a45c461..50bfb3f5754585e5d8d08c91eea82b0b7ab8caf8 100644 (file)
--- a/dump-runlisp-image.c
+++ b/dump-runlisp-image.c
@@ -23,7 +23,7 @@
  * along with Runlisp.  If not, see <https://www.gnu.org/licenses/>.
  */
 
  * along with Runlisp.  If not, see <https://www.gnu.org/licenses/>.
  */
 

-/*----- Header files ------------------------------------------------------*/
+/*----- Header files ---------------------------------------------------------*/

 
 #include "config.h"
 
 
 #include "config.h"
 


@@ -70,6 +70,7 @@ struct linebuf {
 /* Job-state constants. */
 enum {
   JST_READY,                           /* not yet started */
 /* Job-state constants. */
 enum {
   JST_READY,                           /* not yet started */

+  JST_DELETE,                          /* just delete the image file */

   JST_RUN,                             /* currently running */
   JST_DEAD,                            /* process exited */
   JST_NSTATE
   JST_RUN,                             /* currently running */
   JST_DEAD,                            /* process exited */
   JST_NSTATE


@@ -79,6 +80,7 @@ enum {
 struct job {
   struct treap_node _node;             /* treap intrusion */
   struct job *next;                    /* next job in whichever list */
 struct job {
   struct treap_node _node;             /* treap intrusion */
   struct job *next;                    /* next job in whichever list */

+  unsigned op;                         /* operation (`JOP_...') */

   struct argv av;                      /* argument vector to execute */
   char *imgnew, *imgout;               /* staging and final output files */
   unsigned st;                         /* job state (`JST_...') */
   struct argv av;                      /* argument vector to execute */
   char *imgnew, *imgout;               /* staging and final output files */
   unsigned st;                         /* job state (`JST_...') */


@@ -90,8 +92,12 @@ struct job {
 #define JOB_NAME(job) TREAP_NODE_KEY(job)
 #define JOB_NAMELEN(job) TREAP_NODE_KEYLEN(job)
 
 #define JOB_NAME(job) TREAP_NODE_KEY(job)
 #define JOB_NAMELEN(job) TREAP_NODE_KEYLEN(job)
 

-static struct treap jobs = TREAP_INIT; /* Lisp systems scheduled to dump */
-static struct job *job_ready, *job_run, *job_dead; /* list jobs by state */
+static struct treap jobs = TREAP_INIT, /* Lisp systems seen so far */
+  good = TREAP_INIT;                   /* files ok to be in image dir */
+static struct job                      /* lists of jobs by state */
+  *job_ready, **job_ready_tail = &job_ready, /* some have tail pointers... */
+  *job_delete, **job_delete_tail = &job_delete,
+  *job_run, *job_dead;                 /* ... and some don't */

 static unsigned nrun, maxrun = 1;      /* running and maximum job counts */
 static int rc = 0;                     /* code that we should return */
 static int nullfd;                     /* file descriptor for `/dev/null' */
 static unsigned nrun, maxrun = 1;      /* running and maximum job counts */
 static int rc = 0;                     /* code that we should return */
 static int nullfd;                     /* file descriptor for `/dev/null' */


@@ -108,6 +114,9 @@ static unsigned flags = 0;          /* flags for the application */
 #define AF_ALL 0x0008u                 /*   dump all known Lisps */
 #define AF_FORCE 0x0010u               /*   dump even if images exist */
 #define AF_CHECKINST 0x0020u           /*   check Lisp exists before dump */
 #define AF_ALL 0x0008u                 /*   dump all known Lisps */
 #define AF_FORCE 0x0010u               /*   dump even if images exist */
 #define AF_CHECKINST 0x0020u           /*   check Lisp exists before dump */

+#define AF_REMOVE 0x0040u              /*   remove selected Lisp images */
+#define AF_CLEAN 0x0080u               /*   remove other Lisp images */
+#define AF_JUNK 0x0100u                        /*   remove unrecognized files */

 
 /*----- Miscellany --------------------------------------------------------*/
 
 
 /*----- Miscellany --------------------------------------------------------*/
 


@@ -490,60 +499,112 @@ static void prefix_lines(struct job *job, struct linebuf *buf, char marker)
 
 /*----- Job management ----------------------------------------------------*/
 
 
 /*----- Job management ----------------------------------------------------*/
 

-/* Add a new job to the `ready' queue.
+/* Consider a Lisp system description and maybe add a job to the right queue.

  *
  *

- * The job will be to dump the Lisp system with the given LEN-byte NAME.  On
- * entry, *TAIL_INOUT should point to the `next' link of the last node in the
- * list (or the list head pointer), and will be updated on exit.
+ * The Lisp system is described by the configuration section SECT.  Most of
+ * the function is spent on inspecting this section for suitability and
+ * deciding what to do about it.

  *
  *

- * This function reports (fatal) errors for most kinds of problems.  If
- * `JF_QUIET' is set in F then silently ignore a well-described Lisp system
- * which nonetheless isn't suitable.  (This is specifically intended for the
- * case where we try to dump all known Lisp systems, but some don't have a
- * `dump-image' command.)
+ * The precise behaviour depends on F, which should be the bitwise-OR of a
+ * `JQ_...' constant and zero or more flags, as follows.
+ *
+ *   * The bits covered by `JMASK_QUEUE' identify which queue the job should
+ *     be added to if the section defines a cromulent Lisp system:
+ *
+ *       -- `JQ_NONE' -- don't actually make a job at all;
+ *       -- `JQ_READY' -- add the Lisp to the `job_ready' queue, so we'll; or
+ *       -- `JQ_DELETE' -- add the Lisp to the `job_delete' queue.
+ *
+ *   * `JF_PICKY': The user identified this Lisp system explicitly, so
+ *     complain if the configuration section doesn't look right.  This is
+ *     clear if the caller is just enumerating all of the configuration
+ *     sections: without this feature, we'd be checking everything twice,
+ *     which (a) is inefficient, and -- more importantly -- (b) could lead to
+ *     problems if the two checks are inconsistent.
+ *
+ *   * `JF_CHECKINST': Ignore this Lisp if `AF_CHECKINST' is set and it's not
+ *     actually installed.  (This is usually set for `JQ_READY' calls, so
+ *     that we don't try to dump Lisps which aren't there, but clear for
+ *     `JQ_DELETE' calls so that we clear out Lisps which have gone away.)
+ *
+ *   * `JF_CHECKEXIST': Ignore this Lisp if its image file already exists.
+ *
+ *   * `JF_NOTICE': Record the Lisp's image basename in the `good' treap so
+ *     that we can identify everything else we find in the image directory as
+ *     junk.

  */
  */

-#define JF_QUIET 1u
-static void add_job(struct job ***tail_inout, unsigned f,
-                   const char *name, size_t len)
+#define JMASK_QUEUE 3u                 /* which queue to add good Lisp to */
+#define JQ_NONE 0u                     /*   don't add to any queue */
+#define JQ_READY 1u                    /*   `job_ready' */
+#define JQ_DELETE 2u                   /*   `job_delete' */
+#define JF_PICKY 4u                    /* lose if section isn't Lisp defn */
+#define JF_CHECKINST 8u                        /* maybe check Lisp is installed */
+#define JF_CHECKEXIST 16u              /* skip if image already exists */
+#define JF_NOTICE 32u                  /* record Lisp's image basename */
+
+#define JADD_NAMED (JQ_READY | JF_PICKY | JF_CHECKINST)
+#define JADD_DEFAULT (JQ_READY | JF_CHECKINST)
+#define JADD_CLEANUP (JQ_DELETE)
+#define JADD_NOTICE (JQ_NONE)
+static void add_job(unsigned f, struct config_section *sect)

 {
 {

-  struct job *job;
-  struct treap_path path;
-  struct config_section *sect;
+  const char *name;
+  struct job *job, ***tail;
+  struct treap_path path, jobpath;

   struct config_var *dumpvar, *cmdvar, *imgvar;
   struct config_var *dumpvar, *cmdvar, *imgvar;

+  struct treap_node *n;

   struct dstr d = DSTR_INIT;
   struct argv av = ARGV_INIT;
   char *imgnew = 0, *imgout = 0;
   struct dstr d = DSTR_INIT;
   struct argv av = ARGV_INIT;
   char *imgnew = 0, *imgout = 0;

-  size_t i;
+  size_t i, len;

   unsigned fef;
 
   unsigned fef;
 

-  /* Check to see whether this Lisp system is already queued up. */
-  job = treap_probe(&jobs, name, len, &path);
+  /* We'll want the section's name for all sorts of things. */
+  name = CONFIG_SECTION_NAME(sect);
+  len = CONFIG_SECTION_NAMELEN(sect);
+
+  /* Check to see whether this Lisp system is already queued up.
+   *
+   * We'll get around to adding the new job node to the treap right at the
+   * end, so use a separate path object to keep track of where to put it.
+   */
+  job = treap_probe(&jobs, name, len, &jobpath);

   if (job) {
   if (job) {

-    if (verbose >= 2) {
+    if ((f&JF_PICKY) && verbose >= 1)

       moan("ignoring duplicate Lisp `%s'", JOB_NAME(job));
       moan("ignoring duplicate Lisp `%s'", JOB_NAME(job));

-      return;
-    }
+    goto end;

   }
 
   }
 

-  /* Find the configuration for this Lisp system and check that it can be
-   * dumped.
+  /* Check that the section defines a Lisp, and that it can be dumped.
+   *
+   * It's not obvious that this is right.  Maybe there should be some
+   * additional flag so that we don't check dumpability if we're planning to
+   * delete the image.  But it /is/ right: since the thing which tells us
+   * whether we can dump is that the section tells us the image's name, if
+   * it can't be dumped then we won't know what file to delete!  So we have
+   * no choice.

    */
    */

-  sect = config_find_section_n(&config, 0, name, len);
-  if (!sect) lose("unknown Lisp implementation `%.*s'", (int)len, name);
-  name = CONFIG_SECTION_NAME(sect);
-  dumpvar = config_find_var(&config, sect, 0, "dump-image");
-  if (!dumpvar) {
-    if (!(f&JF_QUIET))
-      lose("don't know how to dump images for Lisp implementation `%s'",
-          name);
+  if (!config_find_var(&config, sect, CF_INHERIT, "run-script")) {
+    if (f&JF_PICKY) lose("unknown Lisp implementation `%s'", name);
+    else if (verbose >= 3) moan("skipping non-Lisp section `%s'", name);
+    goto end;
+  }
+  imgvar = config_find_var(&config, sect, CF_INHERIT, "image-file");
+  if (!imgvar) {
+    if (f&JF_PICKY)
+      lose("Lisp implementation `%s' doesn't use custom images", name);
+    else if (verbose >= 3)
+      moan("skipping Lisp `%s': no custom image support", name);

     goto end;
   }
 
   /* Check that the other necessary variables are present. */
     goto end;
   }
 
   /* Check that the other necessary variables are present. */

-  imgvar = config_find_var(&config, sect, 0, "image-file");
-  if (!imgvar) lose("variable `image-file' not defined for Lisp `%s'", name);
-  cmdvar = config_find_var(&config, sect, 0, "command");
-  if (!cmdvar) lose("variable `command' not defined for Lisp `%s'", name);
+  dumpvar = config_find_var(&config, sect, CF_INHERIT, "dump-image");
+  if (!dumpvar)
+    lose("variable `dump-image' not defined for Lisp `%s'", name);
+  cmdvar = config_find_var(&config, sect, CF_INHERIT, "command");
+  if (!cmdvar)
+    lose("variable `command' not defined for Lisp `%s'", name);

 
   /* Build the job's command line. */
   config_subst_split_var(&config, sect, dumpvar, &av);
 
   /* Build the job's command line. */
   config_subst_split_var(&config, sect, dumpvar, &av);


@@ -557,17 +618,35 @@ static void add_job(struct job ***tail_inout, unsigned f,
    * because that would cause us to spam the user with redundant
    * diagnostics.)
    */
    * because that would cause us to spam the user with redundant
    * diagnostics.)
    */

-  if (flags&AF_CHECKINST) {
+  if ((f&JF_CHECKINST) && (flags&AF_CHECKINST)) {

     dstr_reset(&d);
     dstr_reset(&d);

-    fef = (verbose >= 2 ? FEF_VERBOSE : 0);
+    fef = (verbose >= 3 ? FEF_VERBOSE : 0);

     config_subst_var(&config, sect, cmdvar, &d);
     config_subst_var(&config, sect, cmdvar, &d);

-    if (!found_in_path_p(d.p, fef) ||
-       (STRCMP(d.p, !=, av.v[0]) && !found_in_path_p(av.v[0], fef))) {
-      if (verbose >= 2) moan("skipping Lisp implementation `%s'", name);
+    if (!found_in_path_p(d.p, fef)) {
+      if (verbose >= 3)
+       moan("skipping Lisp `%s': can't find Lisp command `%s'",
+            name, d.p);
+      goto end;
+    }
+    if (STRCMP(d.p, !=, av.v[0]) && !found_in_path_p(av.v[0], fef)) {
+       moan("skipping Lisp `%s': can't find dump command `%s'",
+            av.v[0], d.p);

       goto end;
     }
   }
 
       goto end;
     }
   }
 

+  /* If we're supposed to, then notice that this is the name of a good Lisp
+   * image.
+   */
+  if (f&JF_NOTICE) {
+    dstr_reset(&d); config_subst_var(&config, sect, imgvar, &d);
+    n = treap_probe(&good, d.p, d.len, &path);
+    if (!n) {
+      n = xmalloc(sizeof(*n));
+      treap_insert(&good, &path, n, d.p, d.len);
+    }
+  }
+

   /* Collect the output image file names. */
   imgnew =
     config_subst_string_alloc(&config, sect, "<internal>", "${@image-new}");
   /* Collect the output image file names. */
   imgnew =
     config_subst_string_alloc(&config, sect, "<internal>", "${@image-new}");


@@ -577,11 +656,11 @@ static void add_job(struct job ***tail_inout, unsigned f,
   /* If we're supposed to check whether the image file exists, then we should
    * do that.
    */
   /* If we're supposed to check whether the image file exists, then we should
    * do that.
    */

-  if (!(flags&AF_FORCE)) {
+  if ((f&JF_CHECKEXIST) && !(flags&AF_FORCE)) {

     if (!access(imgout, F_OK)) {
     if (!access(imgout, F_OK)) {

-      if (verbose >= 2)
-       moan("image `%s' already exists: skipping `%s'", d.p, name);
-      goto end;
+      if (verbose >= 3)
+       moan("skipping Lisp `%s': image `%s' already exists", name, imgout);
+      f = (f&~JMASK_QUEUE) | JQ_NONE;

     }
   }
 
     }
   }
 


@@ -589,15 +668,21 @@ static void add_job(struct job ***tail_inout, unsigned f,
    * of the list.  (Steal the command-line vector so that we don't try to
    * free it during cleanup.)
    */
    * of the list.  (Steal the command-line vector so that we don't try to
    * free it during cleanup.)
    */

+  switch (f&JMASK_QUEUE) {
+    case JQ_NONE: tail = 0; break;
+    case JQ_READY: tail = &job_ready_tail; break;
+    case JQ_DELETE: tail = &job_delete_tail; break;
+    default: assert(0);
+  }

   job = xmalloc(sizeof(*job));
   job->st = JST_READY;
   job = xmalloc(sizeof(*job));
   job->st = JST_READY;

-  job->kid = -1;
+  job->kid = -1; job->log = 0;

   job->out.fd = -1; job->out.buf = 0;
   job->err.fd = -1; job->err.buf = 0;
   job->av = av; argv_init(&av);
   job->imgnew = imgnew; job->imgout = imgout; imgnew = imgout = 0;
   job->out.fd = -1; job->out.buf = 0;
   job->err.fd = -1; job->err.buf = 0;
   job->av = av; argv_init(&av);
   job->imgnew = imgnew; job->imgout = imgout; imgnew = imgout = 0;

-  treap_insert(&jobs, &path, &job->_node, name, len);
-  **tail_inout = job; *tail_inout = &job->next;
+  treap_insert(&jobs, &jobpath, &job->_node, name, len);
+  if (tail) { **tail = job; *tail = &job->next; }

 
 end:
   /* All done.  Cleanup time. */
 
 end:
   /* All done.  Cleanup time. */


@@ -606,6 +691,20 @@ end:
   dstr_release(&d); argv_release(&av);
 }
 
   dstr_release(&d); argv_release(&av);
 }
 

+/* As `add_job' above, but look the Lisp implementation up by name.
+ *
+ * The flags passed to `add_job' are augmented with `JF_PICKY' because this
+ * is an explicitly-named Lisp implementation.
+ */
+static void add_named_job(unsigned f, const char *name, size_t len)
+{
+  struct config_section *sect;
+
+  sect = config_find_section_n(&config, 0, name, len);
+  if (!sect) lose("unknown Lisp implementation `%.*s'", (int)len, name);
+  add_job(f | JF_PICKY, sect);
+}
+

 /* Free the JOB and all the resources it holds.
  *
  * Close the pipes; kill the child process.  Everything must go.
 /* Free the JOB and all the resources it holds.
  *
  * Close the pipes; kill the child process.  Everything must go.


@@ -613,6 +712,7 @@ end:
 static void release_job(struct job *job)
 {
   size_t i;
 static void release_job(struct job *job)
 {
   size_t i;

+  struct job *j;

 
   if (job->kid > 0) kill(job->kid, SIGKILL); /* ?? */
   if (job->log && job->log != stdout) fclose(job->log);
 
   if (job->kid > 0) kill(job->kid, SIGKILL); /* ?? */
   if (job->log && job->log != stdout) fclose(job->log);


@@ -621,6 +721,7 @@ static void release_job(struct job *job)
   argv_release(&job->av);
   free(job->out.buf); if (job->out.fd >= 0) close(job->out.fd);
   free(job->err.buf); if (job->err.fd >= 0) close(job->err.fd);
   argv_release(&job->av);
   free(job->out.buf); if (job->out.fd >= 0) close(job->out.fd);
   free(job->err.buf); if (job->err.fd >= 0) close(job->err.fd);

+  j = treap_remove(&jobs, JOB_NAME(job), JOB_NAMELEN(job)); assert(j == job);

   free(job);
 }
 
   free(job);
 }
 


@@ -761,6 +862,22 @@ static void start_jobs(void)
     job = job_ready; job_ready = job->next;
     p_out[0] = p_out[1] = p_err[0] = p_err[1] = -1;
 
     job = job_ready; job_ready = job->next;
     p_out[0] = p_out[1] = p_err[0] = p_err[1] = -1;
 

+    /* If we're not actually going to do anything, now is the time to not do
+     * that.
+     */
+    if (flags&AF_DRYRUN) {
+      if (try_exec(&job->av,
+                  TEF_DRYRUN |
+                  (verbose >= 2 && !(flags&AF_CHECKINST) ?
+                   TEF_VERBOSE : 0)))
+         rc = 127;
+       else if (verbose >= 2)
+         printf("%-13s > not dumping `%s' (dry run)\n",
+                JOB_NAME(job), JOB_NAME(job));
+      release_job(job);
+      continue;
+    }
+

     /* Make a temporary subdirectory for this job to use. */
     dstr_reset(&d); dstr_putf(&d, "%s/%s", tmpdir, JOB_NAME(job));
     if (mkdir(d.p, 0700)) {
     /* Make a temporary subdirectory for this job to use. */
     dstr_reset(&d); dstr_putf(&d, "%s/%s", tmpdir, JOB_NAME(job));
     if (mkdir(d.p, 0700)) {


@@ -926,6 +1043,10 @@ static void run_jobs(void)
      * output.
      */
     for (link = &job_dead, job = *link; job; job = next) {
      * output.
      */
     for (link = &job_dead, job = *link; job; job = next) {

+      if (job->out.fd >= 0 && FD_ISSET(job->out.fd, &fd_in))
+       prefix_lines(job, &job->out, '|');
+      if (job->err.fd >= 0 && FD_ISSET(job->err.fd, &fd_in))
+       prefix_lines(job, &job->err, '*');

       next = job->next;
       if (job->out.fd >= 0 || job->err.fd >= 0) link = &job->next;
       else { *link = next; finish_job(job); }
       next = job->next;
       if (job->out.fd >= 0 || job->err.fd >= 0) link = &job->next;
       else { *link = next; finish_job(job); }


@@ -942,7 +1063,7 @@ static void version(FILE *fp)
 static void usage(FILE *fp)
 {
   fprintf(fp, "\
 static void usage(FILE *fp)
 {
   fprintf(fp, "\

-usage: %s [-afnqv] [-c CONF] [-o [SECT:]VAR=VAL]\n\
+usage: %s [-RUadfinqrv] [+RUdfinr] [-c CONF] [-o [SECT:]VAR=VAL]\n\

        [-O FILE|DIR] [-j NJOBS] [LISP ...]\n",
          progname);
 }
        [-O FILE|DIR] [-j NJOBS] [LISP ...]\n",
          progname);
 }


@@ -966,13 +1087,33 @@ Configuration:\n\
 \n\
 Image dumping:\n\
   -O, --output=FILE|DIR                Store image(s) in FILE or DIR.\n\
 \n\
 Image dumping:\n\
   -O, --output=FILE|DIR                Store image(s) in FILE or DIR.\n\

-  -a, --all-configured         Dump all implementations configured.\n\
+  -R, --remove-other           Delete image files for other Lisp systems.\n\
+  -U, --remove-unknown         Delete unrecognized files in image dir.\n\
+  -a, --all-configured         Select all configured implementations.\n\
+  -d, --cleanup                        Delete images which are no longer wanted.\n\

   -f, --force                  Dump images even if they already exist.\n\
   -f, --force                  Dump images even if they already exist.\n\

-  -i, --check-installed                Check Lisp systems exist before invoking.\n\
-  -j, --jobs=NJOBS             Run up to NJOBS jobs in parallel.\n",
+  -i, --check-installed                Check Lisp systems exist before dumping.\n\
+  -j, --jobs=NJOBS             Run up to NJOBS jobs in parallel.\n\
+  -r, --remove-image           Delete image files, instead of creating.\n",

        fp);
 }
 
        fp);
 }
 

+static void show_job_list(const char *what, struct job *job)
+{
+  struct dstr d = DSTR_INIT;
+  int first;
+
+  first = 1;
+  for (; job; job = job->next) {
+    if (first) first = 0;
+    else dstr_puts(&d, ", ");
+    dstr_putf(&d, "`%s'", JOB_NAME(job));
+  }
+  if (first) dstr_puts(&d, "(none)");
+  dstr_putz(&d);
+  moan("%s: %s", what, d.p);
+}
+

 /* Main program. */
 int main(int argc, char *argv[])
 {
 /* Main program. */
 int main(int argc, char *argv[])
 {


@@ -980,16 +1121,22 @@ int main(int argc, char *argv[])
   struct config_section *sect;
   struct config_var *var;
   const char *out = 0, *p, *q, *l;
   struct config_section *sect;
   struct config_var *var;
   const char *out = 0, *p, *q, *l;

-  struct job *job, **tail;
+  struct job *job;

   struct stat st;
   struct dstr d = DSTR_INIT;
   struct stat st;
   struct dstr d = DSTR_INIT;

-  int i, fd, first;
+  DIR *dir;
+  struct dirent *de;
+  int i, fd;
+  size_t n, o;
+  unsigned f;

 
   /* Command-line options. */
   static const struct option opts[] = {
     { "help",                  0,              0,      'h' },
     { "version",               0,              0,      'V' },
     { "output",                        OPTF_ARGREQ,    0,      'O' },
 
   /* Command-line options. */
   static const struct option opts[] = {
     { "help",                  0,              0,      'h' },
     { "version",               0,              0,      'V' },
     { "output",                        OPTF_ARGREQ,    0,      'O' },

+    { "remove-other",          OPTF_NEGATE,    0,      'R' },
+    { "remove-unknown",                OPTF_NEGATE,    0,      'U' },

     { "all-configured",                0,              0,      'a' },
     { "config-file",           OPTF_ARGREQ,    0,      'c' },
     { "force",                 OPTF_NEGATE,    0,      'f' },
     { "all-configured",                0,              0,      'a' },
     { "config-file",           OPTF_ARGREQ,    0,      'c' },
     { "force",                 OPTF_NEGATE,    0,      'f' },


@@ -998,6 +1145,7 @@ int main(int argc, char *argv[])
     { "dry-run",               OPTF_NEGATE,    0,      'n' },
     { "set-option",            OPTF_ARGREQ,    0,      'o' },
     { "quiet",                 0,              0,      'q' },
     { "dry-run",               OPTF_NEGATE,    0,      'n' },
     { "set-option",            OPTF_ARGREQ,    0,      'o' },
     { "quiet",                 0,              0,      'q' },

+    { "remove-image",          OPTF_NEGATE,    0,      'r' },

     { "verbose",               0,              0,      'v' },
     { 0,                       0,              0,      0 }
   };
     { "verbose",               0,              0,      'v' },
     { 0,                       0,              0,      0 }
   };


@@ -1008,30 +1156,41 @@ int main(int argc, char *argv[])
 
   /* Parse the options. */
   optprog = (/*unconst*/ char *)progname;
 
   /* Parse the options. */
   optprog = (/*unconst*/ char *)progname;

+
+#define FLAGOPT(ch, f)                                                 \
+  case ch:                                                             \
+    flags |= f;                                                                \
+    break;                                                             \
+  case ch | OPTF_NEGATED:                                              \
+    flags &= ~f;                                                       \
+    break
+

   for (;;) {
   for (;;) {

-    i = mdwopt(argc - 1, argv + 1, "hVO:ac:f+i+j:n+o:qv", opts, 0, 0,
+    i = mdwopt(argc - 1, argv + 1, "hVO:R+U+ac:d+f+i+j:n+o:qr+v", opts, 0, 0,

               OPTF_NEGATION | OPTF_NOPROGNAME);
     if (i < 0) break;
     switch (i) {
       case 'h': help(stdout); exit(0);
       case 'V': version(stdout); exit(0);
       case 'O': out = optarg; break;
               OPTF_NEGATION | OPTF_NOPROGNAME);
     if (i < 0) break;
     switch (i) {
       case 'h': help(stdout); exit(0);
       case 'V': version(stdout); exit(0);
       case 'O': out = optarg; break;

+      FLAGOPT('R', AF_CLEAN);
+      FLAGOPT('U', AF_JUNK);

       case 'a': flags |= AF_ALL; break;
       case 'c': read_config_path(optarg, 0); flags |= AF_SETCONF; break;
       case 'a': flags |= AF_ALL; break;
       case 'c': read_config_path(optarg, 0); flags |= AF_SETCONF; break;

-      case 'f': flags |= AF_FORCE; break;
-      case 'f' | OPTF_NEGATED: flags &= ~AF_FORCE; break;
-      case 'i': flags |= AF_CHECKINST; break;
-      case 'i' | OPTF_NEGATED: flags &= ~AF_CHECKINST; break;
+      FLAGOPT('f', AF_FORCE);
+      FLAGOPT('i', AF_CHECKINST);

       case 'j': maxrun = parse_int("number of jobs", optarg, 1, 65535); break;
       case 'j': maxrun = parse_int("number of jobs", optarg, 1, 65535); break;

-      case 'n': flags |= AF_DRYRUN; break;
-      case 'n' | OPTF_NEGATED: flags &= ~AF_DRYRUN; break;
+      FLAGOPT('n', AF_DRYRUN);

       case 'o': if (set_config_var(optarg)) flags |= AF_BOGUS; break;
       case 'q': if (verbose) verbose--; break;
       case 'o': if (set_config_var(optarg)) flags |= AF_BOGUS; break;
       case 'q': if (verbose) verbose--; break;

+      FLAGOPT('r', AF_REMOVE);

       case 'v': verbose++; break;
       default: flags |= AF_BOGUS; break;
     }
   }
 
       case 'v': verbose++; break;
       default: flags |= AF_BOGUS; break;
     }
   }
 

+#undef FLAGOPT
+

   /* CHeck that everything worked. */
   optind++;
   if ((flags&AF_ALL) ? optind < argc : optind >= argc) flags |= AF_BOGUS;
   /* CHeck that everything worked. */
   optind++;
   if ((flags&AF_ALL) ? optind < argc : optind >= argc) flags |= AF_BOGUS;


@@ -1084,6 +1243,10 @@ int main(int argc, char *argv[])
                   "@image-out", "${@BUILTIN:@%out-dir}/${image-file}");
   } else if (argc - optind != 1)
     lose("can't dump multiple Lisps to a single output file");
                   "@image-out", "${@BUILTIN:@%out-dir}/${image-file}");
   } else if (argc - optind != 1)
     lose("can't dump multiple Lisps to a single output file");

+  else if (flags&AF_JUNK)
+    lose("can't clear junk in a single output file");
+  else if (flags&AF_CLEAN)
+    lose("can't clean other images with a single output file");

   else
     config_set_var(&config, builtin, CF_LITERAL, "@image-out", out);
 
   else
     config_set_var(&config, builtin, CF_LITERAL, "@image-out", out);
 


@@ -1093,83 +1256,166 @@ int main(int argc, char *argv[])
   /* Dump the final configuration if we're being very verbose. */
   if (verbose >= 5) dump_config();
 
   /* Dump the final configuration if we're being very verbose. */
   if (verbose >= 5) dump_config();
 

-  /* Create jobs for the Lisp systems we're supposed to be dumping. */
-  tail = &job_ready;
-  if (!(flags&AF_ALL))
-    for (i = optind; i < argc; i++)
-      add_job(&tail, 0, argv[i], strlen(argv[i]));
-  else {
-    /* So we're supposed to dump `all' of them.  If there's a `dump'
+  /* There are a number of different strategies we might employ, depending on
+   * the exact request.
+   *
+   *                           queue           queue           clear
+   *   REMOVE  CLEAN   JUNK    selected        others          junk?
+   *
+   *   *       nil     nil     ready/delete    --              no
+   *   *       nil     t       ready/delete    none            yes
+   *   nil     t       nil     ready           delete          no
+   *   nil     t       t       ready           --              yes
+   *   t       t       nil     --              delete          no
+   *   t       t       t       --              --              yes
+   */
+
+  /* First step: if `AF_REMOVE' and `AF_CLEAN' are not both set, then scan
+   * the selected Lisp systems and add them to the appropriate queue.
+   *
+   * Bit-hack: if they are not both set, then their complements are not both
+   * clear.
+   */
+  if (~flags&(AF_REMOVE | AF_CLEAN)) {
+
+    /* Determine the flags for `add_job' when we select the Lisp systems.  If
+     * we intend to clear junk then we must notice the image names we
+     * encounter.  If we're supposed to check that Lisps exist before dumping
+     * then do that -- but it doesn't make any sense for deletion.
+     */
+    f = flags&AF_REMOVE ? JQ_DELETE : JQ_READY;
+    if (flags&AF_JUNK) f |= JF_NOTICE;
+    if (flags&AF_CHECKINST) f |= JF_CHECKINST;
+    if (!(flags&(AF_FORCE | AF_REMOVE))) f |= JF_CHECKEXIST;
+
+    /* If we have named Lisps, then process them. */
+    if (!(flags&AF_ALL))
+      for (i = optind; i < argc; i++)
+       add_named_job(f, argv[i], strlen(argv[i]));
+
+    /* Otherwise we're supposed to dump `all' of them.  If there's a `dump'

      * configuration setting then we need to parse that.  Otherwise we just
      * try all of them.
      */
      * configuration setting then we need to parse that.  Otherwise we just
      * try all of them.
      */

-    var = config_find_var(&config, toplevel, 0, "dump");
-    if (!var) {
-      /* No setting.  Just do all of the Lisps which look available. */
-
-      flags |= AF_CHECKINST;
-      for (config_start_section_iter(&config, &si);
-          (sect = config_next_section(&si)); )
-       add_job(&tail, JF_QUIET,
-               CONFIG_SECTION_NAME(sect),
-               CONFIG_SECTION_NAMELEN(sect));
-    } else {
-      /* Parse the `dump' list. */
-
-      p = var->val; l = p + var->n;
-      for (;;) {
-       while (p < l && ISSPACE(*p)) p++;
-       if (p >= l) break;
-       q = p;
-       while (p < l && !ISSPACE(*p) && *p != ',') p++;
-       add_job(&tail, 0, q, p - q);
-       while (p < l && ISSPACE(*p)) p++;
-       if (p < l && *p == ',') p++;
+    else {
+      var = config_find_var(&config, toplevel, CF_INHERIT, "dump");
+      if (!var) {
+       /* No setting.  Just do all of the Lisps which look available. */
+
+       f |= JF_CHECKINST;
+       for (config_start_section_iter(&config, &si);
+            (sect = config_next_section(&si)); )
+         add_job(f, sect);
+      } else {
+       /* Parse the `dump' list. */
+
+       dstr_reset(&d); config_subst_var(&config, toplevel, var, &d);
+       p = d.p; l = p + d.len;
+       for (;;) {
+         while (p < l && ISSPACE(*p)) p++;
+         if (p >= l) break;
+         q = p;
+         while (p < l && !ISSPACE(*p) && *p != ',') p++;
+         add_named_job(f, q, p - q);
+         while (p < l && ISSPACE(*p)) p++;
+         if (p < l && *p == ',') p++;
+       }

       }
     }
   }
       }
     }
   }

-  *tail = 0;
+
+  /* Second step: if exactly one of `AF_CLEAN' and `AF_JUNK' is set, then we
+   * need to scan all of the remaining Lisps and add them to the `delete'
+   * queue.
+   */
+  if (!(flags&AF_CLEAN) != !(flags&AF_JUNK)) {
+
+    /* Determine the flag settings.  If we're junking, then we're not
+     * cleaning -- we just want to mark images belonging to other Lisps as
+     * off-limits to the junking scan.
+     */
+    f = flags&AF_CLEAN ? JQ_DELETE : JQ_NONE | JF_NOTICE;
+
+    /* Now scan the Lisp systems. */
+    for (config_start_section_iter(&config, &si);
+            (sect = config_next_section(&si)); )
+      add_job(f, sect);
+  }
+
+  /* Terminate the job queues. */
+  *job_ready_tail = 0;
+  *job_delete_tail = 0;

 
   /* Report on what it is we're about to do. */
   if (verbose >= 3) {
 
   /* Report on what it is we're about to do. */
   if (verbose >= 3) {

-    dstr_reset(&d);
-    first = 1;
-    for (job = job_ready; job; job = job->next) {
-      if (first) first = 0;
-      else dstr_puts(&d, ", ");
-      dstr_putf(&d, "`%s'", JOB_NAME(job));
-    }
-    if (first) dstr_puts(&d, "(none)");
-    dstr_putz(&d);
-    moan("dumping Lisps: %s", d.p);
+    show_job_list("dumping Lisp images", job_ready);
+    show_job_list("deleting Lisp images", job_delete);

   }
 
   }
 

-  /* If we're not actually going to do anything after all then now's the time
-   * to, err, not do that.
-   */
-  if (flags&AF_DRYRUN) {
-    for (job = job_ready; job; job = job->next) {
-      if (try_exec(&job->av,
-                  TEF_DRYRUN |
-                    (verbose >= 2 && !(flags&AF_CHECKINST) ?
-                      TEF_VERBOSE : 0)))
-       rc = 2;
-      else if (verbose >= 2)
-       printf("%-13s > (not dumping `%s': dry run)\n",
-               JOB_NAME(job), JOB_NAME(job));
-    }
-    return (rc);
-  }
+  /* If there turns out to be nothing to do, then mention this. */
+  if (!(flags&AF_REMOVE) && verbose >= 2 && !job_ready)
+    moan("no Lisp images to dump");

 
 

-  /* Run the jobs. */
+  /* Run the dumping jobs. */

   run_jobs();
 
   run_jobs();
 

-  /* Finally, check for any last signals.  If we hit any fatal signals then
-   * we should kill ourselves so that the exit status will be right.
+  /* Check for any last signals.  If we hit any fatal signals then we should
+   * kill ourselves so that the exit status will be right.

    */
   check_signals();
   if (sigloss) { cleanup(); signal(sigloss, SIG_DFL); raise(sigloss); }
 
    */
   check_signals();
   if (sigloss) { cleanup(); signal(sigloss, SIG_DFL); raise(sigloss); }
 

+  /* Now delete Lisps which need deleting. */
+  while (job_delete) {
+    job = job_delete; job_delete = job->next;
+    if (flags&AF_DRYRUN) {
+      if (verbose >= 2)
+       moan("not deleting `%s' image `%s' (dry run)",
+            JOB_NAME(job), job->imgout);
+    } else {
+      if (verbose >= 2)
+       moan("deleting `%s' image `%s' (dry run)",
+            JOB_NAME(job), job->imgout);
+      if (unlink(job->imgout) && errno != ENOENT)
+       bad("failed to delete `%s' image `%s': %s",
+           JOB_NAME(job), job->imgout, strerror(errno));
+    }
+  }
+
+  /* Finally, maybe delete all of the junk files in the image directory. */
+  if (flags&AF_JUNK) {
+    if (!out) {
+      var = config_find_var(&config, builtin, CF_INHERIT, "@image-dir");
+      assert(var); out = config_subst_var_alloc(&config, builtin, var);
+    }
+    dir = opendir(out);
+    if (!dir)
+      lose("failed to open image directory `%s': %s", out, strerror(errno));
+    dstr_reset(&d);
+    dstr_puts(&d, out); dstr_putc(&d, '/'); o = d.len;
+    if (verbose >= 2)
+      moan("cleaning up junk in image directory `%s'", out);
+    for (;;) {
+      de = readdir(dir); if (!de) break;
+      if (de->d_name[0] == '.' &&
+         (!de->d_name[1] || (de->d_name[1] == '.' && !de->d_name[2])))
+       continue;
+      n = strlen(de->d_name);
+      d.len = o; dstr_putm(&d, de->d_name, n + 1);
+      if (!treap_lookup(&good, de->d_name, n)) {
+       if (flags&AF_DRYRUN) {
+         if (verbose >= 2)
+           moan("not deleting junk file `%s' (dry run)", d.p);
+       } else {
+         if (verbose >= 2)
+           moan("deleting junk file `%s'", d.p);
+         if (unlink(d.p) && errno != ENOENT)
+           bad("failed to delete junk file `%s': %s", d.p, strerror(errno));
+       }
+      }
+    }
+  }
+

   /* All done! */
   return (rc);
 }
   /* All done! */
   return (rc);
 }