-/* Copyright (C) 1994, 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
+/* Copyright (C) 1994, 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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 2.1 of the License, or (at your option) any later version.
*
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
/* "script.c" argv tricks for `#!' scripts.
Authors: Aubrey Jaffer and Jim Blandy */
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
#include <stdio.h>
+#include <errno.h>
#include <ctype.h>
-#include "_scm.h"
-#include "gh.h"
-#include "load.h"
-#include "version.h"
-#include "script.h"
+#include "libguile/_scm.h"
+#include "libguile/gh.h"
+#include "libguile/load.h"
+#include "libguile/version.h"
+
+#include "libguile/validate.h"
+#include "libguile/script.h"
#ifdef HAVE_STRING_H
#include <string.h>
#include <unistd.h> /* for X_OK define */
#endif
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
+
/* Concatentate str2 onto str1 at position n and return concatenated
string if file exists; 0 otherwise. */
n = strlen (str2);
if (str1)
{
- long len = strlen (str1);
- str1 = (char *) realloc (str1, (scm_sizet) (len + n + 1));
+ size_t len = strlen (str1);
+ str1 = (char *) realloc (str1, (size_t) (len + n + 1));
if (!str1)
return 0L;
strncat (str1 + len, str2, n);
return str1;
}
- str1 = (char *) malloc ((scm_sizet) (n + 1));
+ str1 = (char *) scm_malloc ((size_t) (n + 1));
if (!str1)
return 0L;
str1[0] = 0;
scm_find_executable (const char *name)
{
char tbuf[MAXPATHLEN];
- int i = 0;
+ int i = 0, c;
FILE *f;
/* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */
if ((fgetc (f) == '#') && (fgetc (f) == '!'))
{
while (1)
- switch (tbuf[i++] = fgetc (f))
+ switch (c = fgetc (f))
{
case /*WHITE_SPACES */ ' ':
case '\t':
case '\r':
case '\f':
case EOF:
- tbuf[--i] = 0;
+ tbuf[i] = 0;
fclose (f);
return scm_cat_path (0L, tbuf, 0L);
+ default:
+ tbuf[i++] = c;
+ break;
}
}
fclose (f);
/* Read a \nnn-style escape. We've just read the backslash. */
static int
script_get_octal (FILE *f)
+#define FUNC_NAME "script_get_octal"
{
int i;
int value = 0;
if ('0' <= c && c <= '7')
value = (value * 8) + (c - '0');
else
- scm_wta (SCM_UNDEFINED,
- "malformed script: bad octal backslash escape",
- "script argument parser");
+ SCM_MISC_ERROR ("malformed script: bad octal backslash escape",
+ SCM_EOL);
}
return value;
}
+#undef FUNC_NAME
static int
script_get_backslash (FILE *f)
+#define FUNC_NAME "script_get_backslash"
{
int c = getc (f);
case '4': case '5': case '6': case '7':
ungetc (c, f);
return script_get_octal (f);
-
+
case EOF:
- scm_wta (SCM_UNDEFINED,
- "malformed script: backslash followed by EOF",
- "script argument parser");
+ SCM_MISC_ERROR ("malformed script: backslash followed by EOF", SCM_EOL);
return 0; /* not reached? */
default:
- scm_wta (SCM_UNDEFINED,
- "malformed script: bad backslash sequence",
- "script argument parser");
+ SCM_MISC_ERROR ("malformed script: bad backslash sequence", SCM_EOL);
return 0; /* not reached? */
}
}
+#undef FUNC_NAME
static char *
script_read_arg (FILE *f)
+#define FUNC_NAME "script_read_arg"
{
- int size = 7;
- char *buf = malloc (size + 1);
- int len = 0;
+ size_t size = 7;
+ char *buf = scm_malloc (size + 1);
+ size_t len = 0;
if (! buf)
return 0;
case '\t':
free (buf);
- scm_wta (SCM_UNDEFINED,
- "malformed script: TAB in meta-arguments",
- "argument parser");
+ SCM_MISC_ERROR ("malformed script: TAB in meta-arguments", SCM_EOL);
return 0; /* not reached? */
}
}
}
+#undef FUNC_NAME
static int
char *narg, **nargv;
if (!(argc > 2 && script_meta_arg_P (argv[1])))
return 0L;
- if (!(nargv = (char **) malloc ((1 + nargc) * sizeof (char *))))
+ if (!(nargv = (char **) scm_malloc ((1 + nargc) * sizeof (char *))))
return 0L;
nargv[0] = argv[0];
while (((argi + 1) < argc) && (script_meta_arg_P (argv[argi])))
void
scm_shell_usage (int fatal, char *message)
{
+ FILE *fp = (fatal ? stderr : stdout);
+
if (message)
- fprintf (stderr, "%s\n", message);
+ fprintf (fp, "%s\n", message);
- fprintf (stderr,
+ fprintf (fp,
"Usage: %s OPTION ...\n"
"Evaluate Scheme code, interactively or from a script.\n"
"\n"
- " -s SCRIPT load Scheme source code from FILE, and exit\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"
"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"
" -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"
" -q inhibit loading of user init file\n"
" --emacs enable Emacs protocol (experimental)\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",
+ " \\ read arguments from following script lines\n"
+ "\n"
+ "Please report bugs to bug-guile@gnu.org. (Note that you must\n"
+ "be subscribed to this list first, in order to successfully send\n"
+ "a report to it).\n",
scm_usage_name);
if (fatal)
SCM_SYMBOL (sym_eval_string, "eval-string");
SCM_SYMBOL (sym_command_line, "command-line");
SCM_SYMBOL (sym_begin, "begin");
+SCM_SYMBOL (sym_turn_on_debugging, "turn-on-debugging");
SCM_SYMBOL (sym_load_user_init, "load-user-init");
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_set_x, "set!");
+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.
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*
-
- We load the ice-9 system from here. It might be nicer if the
- libraries initialized from the inner_main function in guile.c (which
- will be auto-generated eventually) could assume ice-9 were already
- loaded. Then again, it might be nice if ice-9 could assume that
- certain libraries were already loaded. The solution is to break up
- ice-9 into modules which can be frozen and statically linked like any
- other module. Then all the modules can describe their dependencies in
- the usual way, and the auto-generated inner_main will do the right
- thing. */
+ */
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)
{
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 */
int interactive = 1; /* Should we go interactive when done? */
int inhibit_user_init = 0; /* Don't load user init file */
int use_emacs_interface = 0;
+ int turn_on_debugging = 0;
+ int dont_turn_on_debugging = 0;
+
int i;
char *argv0 = guile;
for (i = 1; i < argc; i++)
{
- if (! strcmp (argv[i], "-s")) /* load script */
+ if ((! strcmp (argv[i], "-s")) || (argv[i][0] != '-')) /* load script */
{
- if (++i >= argc)
+ 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_NULLP (do_script))
+ if (!scm_is_null (do_script))
{
- SCM_SETCAR (do_script, scm_makfrom0str (argv[i]));
+ 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_makfrom0str (argv[i]),
+ scm_from_locale_string (argv[i]),
SCM_EOL),
tail);
argv0 = argv[i];
if (++i >= argc)
scm_shell_usage (1, "missing argument to `-c' switch");
tail = scm_cons (scm_cons2 (sym_eval_string,
- scm_makfrom0str (argv[i]),
+ scm_from_locale_string (argv[i]),
SCM_EOL),
tail);
i++;
{
if (++i < argc)
tail = scm_cons (scm_cons2 (sym_load,
- scm_makfrom0str (argv[i]),
+ 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], "-e")) /* entry point */
{
if (++i < argc)
- entry_point = gh_symbol2scm (argv[i]);
+ {
+ 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");
}
{
/* We put a dummy "load" expression, and let the -s put the
filename in. */
- if (!SCM_NULLP (do_script))
+ 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;
+ }
+
else if (! strcmp (argv[i], "--emacs")) /* use emacs protocol */
use_emacs_interface = 1;
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 (! strcmp (argv[i], "-h")
|| ! strcmp (argv[i], "--help"))
{
{
/* Print version number. */
printf ("Guile %s\n"
- "Copyright (c) 1995, 1996, 1997 Free Software Foundation\n"
+ "Copyright (c) 1995, 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 Free Software Foundation\n"
"Guile may be distributed under the terms of the GNU General Public Licence;\n"
"certain other uses are permitted as well. For details, see the file\n"
"`COPYING', which is included in the Guile distribution.\n"
"There is no warranty, to the extent permitted by law.\n",
- SCM_CHARS (scm_version ()));
+ scm_to_locale_string (scm_version ()));
exit (0);
}
}
/* Check to make sure the -ds got a -s. */
- if (!SCM_NULLP (do_script))
+ 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
scm_set_program_arguments (argc ? argc - i : 0, argv + i, argv0);
/* If the --emacs switch was set, now is when we process it. */
- {
- SCM vcell = scm_sysintern0_no_module_lookup ("use-emacs-interface");
- SCM_SETCDR (vcell, SCM_BOOL(use_emacs_interface));
- }
+ scm_c_define ("use-emacs-interface", scm_from_bool (use_emacs_interface));
/* Handle the `-e' switch, if it was specified. */
- if (!SCM_NULLP (entry_point))
+ if (!scm_is_null (entry_point))
tail = scm_cons (scm_cons2 (entry_point,
scm_cons (sym_command_line, SCM_EOL),
SCM_EOL),
quit. */
tail = scm_cons (scm_cons (sym_quit, SCM_EOL),
tail);
- /* Allow asyncs (signal handlers etc.) to be run. */
- scm_mask_ints = 0;
}
/* 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 we didn't end with a -c or a -s and didn't supply a -q, load
the user's customization file. */
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, turn on debugging. */
+ if (turn_on_debugging || (interactive && !dont_turn_on_debugging))
+ {
+ tail = scm_cons (scm_cons (sym_turn_on_debugging, SCM_EOL), tail);
+ }
+
{
SCM val = scm_cons (sym_begin, tail);
}
}
- exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc,argv))));
+ exit (scm_exit_status (scm_eval_x (scm_compile_shell_switches (argc, argv),
+ scm_current_module ())));
}
void
scm_init_script ()
{
-#include "script.x"
+#include "libguile/script.x"
}
/*
HCoop / bpt / guile.git / blobdiff