script.c calls out to (ice-9 command-line)

* libguile/script.c (scm_shell_usage): Call (ice-9 command-line)'s
  shell-usage.
  (scm_compile_shell_switches): Likewise, call (ice-9 command-line)'s
  compile-shell-switches.

1 files changed, 16 insertions, 449 deletions

diff --git a/libguile/script.c b/libguile/script.c
index bff7142e8..7f6116242 100644
--- a/libguile/script.c
+++ b/libguile/script.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1994-1998, 2000-2011 Free Software Foundation, Inc.
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
  * as published by the Free Software Foundation; either version 3 of
@@ -357,464 +357,31 @@ char *scm_usage_name = 0;
 void
 scm_shell_usage (int fatal, char *message)
 {
-  FILE  *fp = (fatal ? stderr : stdout);
-
-  if (message)
-    fprintf (fp, "%s\n", message);
-
-  fprintf (fp,
-           "Usage: %s [OPTION]... [FILE]...\n"
-           "Evaluate Scheme code, interactively or from a script.\n"
-           "\n"
-           "  [-s] FILE      load Scheme source code from FILE, and exit\n"
-           "  -c EXPR        evalute Scheme expression EXPR, and exit\n"
-           "  --             stop scanning arguments; run interactively\n\n"
-           "The above switches stop argument processing, and pass all\n"
-           "remaining arguments as the value of (command-line).\n"
-           "If FILE begins with `-' the -s switch is mandatory.\n"
-           "\n"
-           "  -L DIRECTORY   add DIRECTORY to the front of the module load path\n"
-           "  -x EXTENSION   add EXTENSION to the front of the load extensions\n"
-           "  -l FILE        load Scheme source code from FILE\n"
-           "  -e FUNCTION    after reading script, apply FUNCTION to\n"
-           "                 command line arguments\n"
-           "  -ds            do -s script at this point\n"
-           "  --debug        start with debugging evaluator and backtraces\n"
-           "  --no-debug     start with normal evaluator\n"
-           "                 Default is to enable debugging for interactive\n"
-           "                 use, but not for `-s' and `-c'.\n"
-           "  --auto-compile compile source files automatically\n"
-           "  --no-auto-compile disable automatic source file compilation\n"
-           "                 Default is to enable auto-compilation of source\n"
-           "                 files.\n"
-           "  --listen[=P]   Listen on a local port or a path for REPL clients.\n"
-           "                 If P is not given, the default is local port 37146.\n"
-	   "  -q             inhibit loading of user init file\n"
-	   "  --use-srfi=LS  load SRFI modules for the SRFIs in LS,\n"
-	   "                 which is a list of numbers like \"2,13,14\"\n"
-           "  -h, --help     display this help and exit\n"
-           "  -v, --version  display version information and exit\n"
-	   "  \\              read arguments from following script lines\n",
-           scm_usage_name);
-
-  emit_bug_reporting_address ();
-
-  if (fatal)
-    exit (fatal);
+  scm_call_3 (scm_c_private_ref ("ice-9 command-line",
+                                 "shell-usage"),
+              (scm_usage_name
+               ? scm_from_locale_string (scm_usage_name)
+               : scm_from_latin1_string ("guile")),
+              scm_from_bool (fatal),
+              (message
+               ? scm_from_locale_string (message)
+               : SCM_BOOL_F));
 }
 
 
-/* Some symbols used by the command-line compiler.  */
-SCM_SYMBOL (sym_load, "load");
-SCM_SYMBOL (sym_eval_string, "eval-string");
-SCM_SYMBOL (sym_command_line, "command-line");
-SCM_SYMBOL (sym_begin, "begin");
-SCM_SYMBOL (sym_load_user_init, "load-user-init");
-SCM_SYMBOL (sym_ice_9, "ice-9");
-SCM_SYMBOL (sym_top_repl, "top-repl");
-SCM_SYMBOL (sym_quit, "quit");
-SCM_SYMBOL (sym_use_srfis, "use-srfis");
-SCM_SYMBOL (sym_load_path, "%load-path");
-SCM_SYMBOL (sym_load_extensions, "%load-extensions");
-SCM_SYMBOL (sym_set_x, "set!");
-SCM_SYMBOL (sym_sys_load_should_auto_compile, "%load-should-auto-compile");
-SCM_SYMBOL (sym_cons, "cons");
-SCM_SYMBOL (sym_at, "@");
-SCM_SYMBOL (sym_atat, "@@");
-SCM_SYMBOL (sym_main, "main");
-
 /* Given an array of command-line switches, return a Scheme expression
    to carry out the actions specified by the switches.
-
-   If you told me this should have been written in Scheme, I'd
-   probably agree.  I'd say I didn't feel comfortable doing that in
-   the present system.  You'd say, well, fix the system so you are
-   comfortable doing that.  I'd agree again.  *shrug*
  */
 
-static char guile[] = "guile";
-
-static int
-all_symbols (SCM list)
-{
-  while (scm_is_pair (list))
-    {
-      if (!scm_is_symbol (SCM_CAR (list)))
-	return 0;
-      list = SCM_CDR (list);
-    }
-  return 1;
-}
-
 SCM
 scm_compile_shell_switches (int argc, char **argv)
 {
-  SCM tail = SCM_EOL;		/* We accumulate the list backwards,
-				   and then reverse! it before we
-				   return it.  */
-  SCM do_script = SCM_EOL;	/* The element of the list containing
-				   the "load" command, in case we get
-				   the "-ds" switch.  */
-  SCM entry_point = SCM_EOL;	/* for -e switch */
-  SCM user_load_path = SCM_EOL; /* for -L switch */
-  SCM user_extensions = SCM_EOL;/* for -x switch */
-  int interactive = 1;		/* Should we go interactive when done? */
-  int inhibit_user_init = 0;	/* Don't load user init file */
-  int turn_on_debugging = 0;
-  int dont_turn_on_debugging = 0;
-
-  int i;
-  char *argv0 = guile;
-
-  if (argc > 0)
-    {
-      argv0 = argv[0];
-      scm_usage_name = strrchr (argv[0], '/');
-      if (! scm_usage_name)
-	scm_usage_name = argv[0];
-      else
-	scm_usage_name++;
-    }
-  if (! scm_usage_name)
-    scm_usage_name = guile;
-  
-  for (i = 1; i < argc; i++)
-    {
-      if ((! strcmp (argv[i], "-s")) || (argv[i][0] != '-')) /* load script */
-	{
-	  if ((argv[i][0] == '-') && (++i >= argc))
-	    scm_shell_usage (1, "missing argument to `-s' switch");
-
-	  /* If we specified the -ds option, do_script points to the
-	     cdr of an expression like (load #f); we replace the car
-	     (i.e., the #f) with the script name.  */
-	  if (!scm_is_null (do_script))
-	    {
-	      SCM_SETCAR (do_script, scm_from_locale_string (argv[i]));
-	      do_script = SCM_EOL;
-	    }
-	  else
-	    /* Construct an application of LOAD to the script name.  */
-	    tail = scm_cons (scm_cons2 (sym_load,
-					scm_from_locale_string (argv[i]),
-					SCM_EOL),
-			       tail);
-	  argv0 = argv[i];
-	  i++;
-	  interactive = 0;
-	  break;
-	}
-
-      else if (! strcmp (argv[i], "-c")) /* evaluate expr */
-	{
-	  if (++i >= argc)
-	    scm_shell_usage (1, "missing argument to `-c' switch");
-	  tail = scm_cons (scm_cons2 (sym_eval_string,
-				      scm_from_locale_string (argv[i]),
-				      SCM_EOL),
-			   tail);
-	  i++;
-	  interactive = 0;
-	  break;
-	}
-
-      else if (! strcmp (argv[i], "--")) /* end args; go interactive */
-	{
-	  i++;
-	  break;
-	}
-
-      else if (! strcmp (argv[i], "-l")) /* load a file */
-	{
-	  if (++i < argc)
-	    tail = scm_cons (scm_cons2 (sym_load,
-					scm_from_locale_string (argv[i]),
-					SCM_EOL),
-			     tail);
-	  else
-	    scm_shell_usage (1, "missing argument to `-l' switch");
-	}	  
-
-      else if (! strcmp (argv[i], "-L")) /* add to %load-path */
-	{
-	  if (++i < argc)
-	    user_load_path =
-	      scm_cons (scm_list_3 (sym_set_x, 
-				    sym_load_path, 
-				    scm_list_3 (sym_cons,
-						scm_from_locale_string (argv[i]),
-						sym_load_path)),
-			user_load_path);
-	  else
-	    scm_shell_usage (1, "missing argument to `-L' switch");
-	}	  
-
-      else if (! strcmp (argv[i], "-x")) /* add to %load-extensions */
-	{
-	  if (++i < argc)
-	    user_extensions =
-	      scm_cons (scm_list_3 (sym_set_x, 
-				    sym_load_extensions, 
-				    scm_list_3 (sym_cons,
-						scm_from_locale_string (argv[i]),
-						sym_load_extensions)),
-			user_extensions);
-	  else
-	    scm_shell_usage (1, "missing argument to `-x' switch");
-	}
-      
-      else if (! strcmp (argv[i], "-e")) /* entry point */
-	{
-	  if (++i < argc)
-	    {
-	      SCM port 
-		= scm_open_input_string (scm_from_locale_string (argv[i]));
-	      SCM arg1 = scm_read (port);
-	      SCM arg2 = scm_read (port);
-
-	      /* Recognize syntax of certain versions of Guile 1.4 and
-		 transform to (@ MODULE-NAME FUNC).
-	       */
-	      if (scm_is_false (scm_eof_object_p (arg2)))
-		entry_point = scm_list_3 (sym_at, arg1, arg2);
-	      else if (scm_is_pair (arg1)
-		       && !(scm_is_eq (SCM_CAR (arg1), sym_at)
-			    || scm_is_eq (SCM_CAR (arg1), sym_atat))
-		       && all_symbols (arg1))
-		entry_point = scm_list_3 (sym_at, arg1, sym_main);
-	      else
-		entry_point = arg1;
-	    }
-	  else
-	    scm_shell_usage (1, "missing argument to `-e' switch");
-	}
-
-      else if (! strcmp (argv[i], "-ds")) /* do script here */
-	{
-	  /* We put a dummy "load" expression, and let the -s put the
-             filename in.  */
-	  if (!scm_is_null (do_script))
-	    scm_shell_usage (1, "the -ds switch may only be specified once");
-	  do_script = scm_cons (SCM_BOOL_F, SCM_EOL);
-	  tail = scm_cons (scm_cons (sym_load, do_script),
-			   tail);
-	}
-
-      else if (! strcmp (argv[i], "--debug"))
-	{
-	  turn_on_debugging = 1;
-	  dont_turn_on_debugging = 0;
-	}
-
-      else if (! strcmp (argv[i], "--no-debug"))
-	{
-	  dont_turn_on_debugging = 1;
-	  turn_on_debugging = 0;
-	}
-
-      /* Do auto-compile on/off now, because the form itself might need this
-         decision. */
-      else if (! strcmp (argv[i], "--auto-compile"))
-        scm_variable_set_x (scm_c_lookup ("%load-should-auto-compile"),
-                            SCM_BOOL_T);
-
-      else if (! strcmp (argv[i], "--no-auto-compile"))
-        scm_variable_set_x (scm_c_lookup ("%load-should-auto-compile"),
-                            SCM_BOOL_F);
-
-      else if (! strcmp (argv[i], "-q")) /* don't load user init */ 
-	inhibit_user_init = 1;
-
-      else if (! strncmp (argv[i], "--use-srfi=", 11)) /* load SRFIs */ 
-	{
-	  SCM srfis = SCM_EOL;	/* List of requested SRFIs.  */
-	  char * p = argv[i] + 11;
-	  while (*p)
-	    {
-	      long num;
-	      char * end;
-
-	      num = strtol (p, &end, 10);
-	      if (end - p > 0)
-		{
-		  srfis = scm_cons (scm_from_long (num), srfis);
-		  if (*end)
-		    {
-		      if (*end == ',')
-			p = end + 1;
-		      else
-			scm_shell_usage (1, "invalid SRFI specification");
-		    }
-		  else
-		    break;
-		}
-	      else
-		scm_shell_usage (1, "invalid SRFI specification");
-	    }
-	  if (scm_ilength (srfis) <= 0)
-	    scm_shell_usage (1, "invalid SRFI specification");
-	  srfis = scm_reverse_x (srfis, SCM_UNDEFINED);
-	  tail = scm_cons (scm_list_2 (sym_use_srfis,
-				       scm_list_2 (scm_sym_quote, srfis)),
-			   tail);
-	}
-
-      else if (! strncmp (argv[i], "--listen", 8)  /* start a repl server */ 
-               && (argv[i][8] == '\0' || argv[i][8] == '='))
-	{
-          const char default_template[] =
-            "(@@ (system repl server) (spawn-server))";
-          const char port_template[] =
-            "(@@ (system repl server)"
-            "    (spawn-server (make-tcp-server-socket #:port ~a)))";
-          const char path_template[] =
-            "(@@ (system repl server)"
-            "    (spawn-server (make-unix-domain-server-socket #:path ~s)))";
-
-	  SCM form_str = SCM_BOOL_F;
-	  char * p = argv[i] + 8;
-
-          if (*p == '=')
-            {
-              p++;
-              if (*p > '0' && *p <= '9')
-                {
-                  /* --listen=PORT */
-                  SCM port = scm_string_to_number (scm_from_locale_string (p),
-                                                   SCM_UNDEFINED);
-
-                  if (scm_is_false (port))
-                    scm_shell_usage (1, "invalid port for --listen");
-
-                  form_str =
-                    scm_simple_format (SCM_BOOL_F,
-                                       scm_from_locale_string (port_template),
-                                       scm_list_1 (port));
-                }
-              else if (*p == '/')
-                {
-                  /* --listen=/PATH/TO/SOCKET */
-                  SCM path = scm_from_locale_string (p);
-
-                  form_str =
-                    scm_simple_format (SCM_BOOL_F,
-                                       scm_from_locale_string (path_template),
-                                       scm_list_1 (path));
-                }
-              else
-                {
-                  /* unknown --listen arg */
-                  scm_shell_usage (1, "unknown argument to --listen");
-                }
-            }
-          else
-            form_str = scm_from_locale_string (default_template);
-          
-          tail = scm_cons (scm_read (scm_open_input_string (form_str)), tail);
-	}
-
-      else if (! strcmp (argv[i], "-h")
-	       || ! strcmp (argv[i], "--help"))
-	{
-	  scm_shell_usage (0, 0);
-	  exit (EXIT_SUCCESS);
-	}
-
-      else if (! strcmp (argv[i], "-v")
-	       || ! strcmp (argv[i], "--version"))
-	{
-	  /* Print version number.  */
-	  version_etc (stdout, scm_usage_name, PACKAGE_NAME, PACKAGE_VERSION,
-		       /* XXX: Use gettext for the string below.  */
-		       "the Guile developers", NULL);
-	  exit (EXIT_SUCCESS);
-	}
-
-      else
-	{
-	  fprintf (stderr, "%s: Unrecognized switch `%s'\n",
-		   scm_usage_name, argv[i]);
-	  scm_shell_usage (1, 0);
-	}
-    }
-
-  /* Check to make sure the -ds got a -s. */
-  if (!scm_is_null (do_script))
-    scm_shell_usage (1, "the `-ds' switch requires the use of `-s' as well");
-
-  /* Make any remaining arguments available to the
-     script/command/whatever.  */
-  scm_set_program_arguments (argc ? argc - i : 0, argv + i, argv0);
-  
-  /* Handle the `-e' switch, if it was specified.  */
-  if (!scm_is_null (entry_point))
-    tail = scm_cons (scm_cons2 (entry_point,
-				scm_cons (sym_command_line, SCM_EOL),
-				SCM_EOL),
-		       tail);
-
-  /* If we didn't end with a -c or a -s, start the repl.  */
-  if (interactive)
-    {
-      tail = scm_cons (scm_list_1 (scm_list_3
-                                   (sym_at,
-                                    scm_list_2 (sym_ice_9, sym_top_repl),
-                                    sym_top_repl)),
-                       tail);
-    }
-  else
-    {
-      /* After doing all the other actions prescribed by the command line,
-	 quit.  */
-      tail = scm_cons (scm_cons (sym_quit, SCM_EOL),
-		       tail);
-    }
-
-  /* After the following line, actions will be added to the front. */
-  tail = scm_reverse_x (tail, SCM_UNDEFINED);
-
-  /* add the user-specified load path here, so it won't be in effect
-     during the loading of the user's customization file. */
-  if(!scm_is_null(user_load_path)) 
-    {
-      tail = scm_append_x( scm_cons2(user_load_path, tail, SCM_EOL) );
-    }
-
-  if (!scm_is_null (user_extensions))
-    tail = scm_append_x (scm_cons2 (user_extensions, tail, SCM_EOL));
-
-  /* If we didn't end with a -c or a -s and didn't supply a -q, load
-     the user's customization file.  */
-  if (interactive && !inhibit_user_init)
-    {
-      tail = scm_cons (scm_cons (sym_load_user_init, SCM_EOL), tail);
-    }
-
-  /* If debugging was requested, or we are interactive and debugging
-     was not explicitly turned off, use the debug engine. */
-  if (turn_on_debugging || (interactive && !dont_turn_on_debugging))
-    {
-      scm_c_set_default_vm_engine_x (SCM_VM_DEBUG_ENGINE);
-      scm_c_set_vm_engine_x (scm_the_vm (), SCM_VM_DEBUG_ENGINE);
-    }
-
-  {
-    SCM val = scm_cons (sym_begin, tail);
-
-    /* Wrap the expression in a prompt. */
-    val = scm_list_2 (scm_list_3 (scm_sym_at,
-                                      scm_list_2 (scm_from_latin1_symbol ("ice-9"),
-                                                  scm_from_latin1_symbol ("control")),
-                                      scm_from_latin1_symbol ("%")),
-                      val);
-
-#if 0
-    scm_write (val, SCM_UNDEFINED);
-    scm_newline (SCM_UNDEFINED);
-#endif
-    
-    return val;
-  }
+  return scm_call_2 (scm_c_public_ref ("ice-9 command-line",
+                                       "compile-shell-switches"),
+                     scm_makfromstrs (argc, argv),
+                     (scm_usage_name
+                      ? scm_from_locale_string (scm_usage_name)
+                      : scm_from_latin1_string ("guile")));
 }