[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.0-188-ge07f0
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.0-188-ge07f0a5 |
|
Date: |
Thu, 14 Apr 2011 14:18:45 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=e07f0a55660b6329089ab88103502094bda2b98e
The branch, stable-2.0 has been updated
via e07f0a55660b6329089ab88103502094bda2b98e (commit)
via 1693983a61de92a7a29b99e9769774fbb9b90942 (commit)
via 26ac1e3f421f1ef735679f595b3345fdb49336e2 (commit)
via da5d81a1f7a3b51813dba2c5a78b8e17243cde52 (commit)
via 56e313894bc865f2b8f4d2b79f5952f8e7b28807 (commit)
from 7c81eba25b0ec03b2b6ab2f22d1f1b74d20691ce (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit e07f0a55660b6329089ab88103502094bda2b98e
Author: Andy Wingo <address@hidden>
Date: Thu Apr 14 16:18:56 2011 +0200
guile -v prints LGPLv3+.
* module/ice-9/command-line.scm (compile-shell-switches): Though Guile
may be distributed under the GPLv3, Guile is actually LGPLv3+.
commit 1693983a61de92a7a29b99e9769774fbb9b90942
Author: Andy Wingo <address@hidden>
Date: Thu Apr 14 16:15:47 2011 +0200
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.
commit 26ac1e3f421f1ef735679f595b3345fdb49336e2
Author: Andy Wingo <address@hidden>
Date: Thu Apr 14 16:06:40 2011 +0200
add packager info to %build-info
* libguile/load.c (init_build_info): Add packager, packager-version, and
packager-bug-reports to %build-info, if they are available.
commit da5d81a1f7a3b51813dba2c5a78b8e17243cde52
Author: Andy Wingo <address@hidden>
Date: Thu Apr 14 16:06:07 2011 +0200
add (ice-9 command-line)
* module/ice-9/command-line.scm: New module for parsing Guile's command
line, ported from script.c. Includes local eval-string implementation
to make `guile -c 1' faster, by not having to load the compiler.
* module/Makefile.am: Add to build.
commit 56e313894bc865f2b8f4d2b79f5952f8e7b28807
Author: Andy Wingo <address@hidden>
Date: Thu Apr 14 16:04:18 2011 +0200
don't warn about non-literal fmt strings for e.g. (_ "foo")
* module/language/tree-il/analyze.scm (const-fmt, format-analysis):
Allow format strings to be gettexted, using the conventional _ name.
-----------------------------------------------------------------------
Summary of changes:
libguile/load.c | 15 ++
libguile/script.c | 465 ++---------------------------------
module/Makefile.am | 1 +
module/ice-9/command-line.scm | 417 +++++++++++++++++++++++++++++++
module/language/tree-il/analyze.scm | 28 ++-
5 files changed, 475 insertions(+), 451 deletions(-)
create mode 100644 module/ice-9/command-line.scm
diff --git a/libguile/load.c b/libguile/load.c
index c2380b9..701b34b 100644
--- a/libguile/load.c
+++ b/libguile/load.c
@@ -933,6 +933,21 @@ init_build_info ()
SCM val = scm_from_locale_string (info[i].value);
*loc = scm_acons (key, val, *loc);
}
+#ifdef PACKAGE_PACKAGER
+ *loc = scm_acons (scm_from_latin1_symbol ("packager"),
+ scm_from_latin1_string (PACKAGE_PACKAGER),
+ *loc);
+#endif
+#ifdef PACKAGE_PACKAGER_VERSION
+ *loc = scm_acons (scm_from_latin1_symbol ("packager-version"),
+ scm_from_latin1_string (PACKAGE_PACKAGER_VERSION),
+ *loc);
+#endif
+#ifdef PACKAGE_PACKAGER_BUG_REPORTS
+ *loc = scm_acons (scm_from_latin1_symbol ("packager-bug-reports"),
+ scm_from_latin1_string (PACKAGE_PACKAGER_BUG_REPORTS),
+ *loc);
+#endif
}
diff --git a/libguile/script.c b/libguile/script.c
index bff7142..7f61162 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")));
}
diff --git a/module/Makefile.am b/module/Makefile.am
index 2685a3a..42aff18 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -181,6 +181,7 @@ ICE_9_SOURCES = \
ice-9/and-let-star.scm \
ice-9/binary-ports.scm \
ice-9/calling.scm \
+ ice-9/command-line.scm \
ice-9/common-list.scm \
ice-9/control.scm \
ice-9/curried-definitions.scm \
diff --git a/module/ice-9/command-line.scm b/module/ice-9/command-line.scm
new file mode 100644
index 0000000..9fa7135
--- /dev/null
+++ b/module/ice-9/command-line.scm
@@ -0,0 +1,417 @@
+;;; Parsing Guile's command-line
+
+;;; 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 the License, or (at your option) any later version.
+;;;;
+;;;; 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.
+;;;;
+;;;; 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
+
+;;; Code:
+
+;;;
+;;; Please be careful not to load up other modules in this file, unless
+;;; they are explicitly requested. Loading modules currently imposes a
+;;; speed penalty of a few stats, an mmap, and some allocation, which
+;;; can range from 1 to 20ms, depending on the state of your disk cache.
+;;; Since `compile-shell-switches' is called even for the most transient
+;;; of command-line programs, we need to keep it lean.
+;;;
+;;; Generally speaking, the goal is for Guile to boot and execute simple
+;;; expressions like "1" within 20ms or less, measured using system time
+;;; from the time of the `guile' invocation to exit.
+;;;
+
+(define-module (ice-9 command-line)
+ #:autoload (system vm vm) (set-default-vm-engine! set-vm-engine! the-vm)
+ #:export (compile-shell-switches
+ version-etc
+ *GPLv3+*
+ *LGPLv3+*
+ emit-bug-reporting-address))
+
+;; An initial stab at i18n.
+(define _ gettext)
+
+(define *GPLv3+*
+ (_ "License GPLv3+: GNU GPL version 3 or later
<http://gnu.org/licenses/gpl.html>.
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law."))
+
+(define *LGPLv3+*
+ (_ "License LGPLv3+: GNU LGPL 3 or later <http://gnu.org/licenses/lgpl.html>.
+This is free software: you are free to change and redistribute it.
+There is NO WARRANTY, to the extent permitted by law."))
+
+;; Display the --version information in the
+;; standard way: command and package names, package version, followed
+;; by a short license notice and a list of up to 10 author names.
+;; If COMMAND_NAME is NULL, the PACKAGE is asumed to be the name of
+;; the program. The formats are therefore:
+;; PACKAGE VERSION
+;; or
+;; COMMAND_NAME (PACKAGE) VERSION.
+;;
+;; Based on the version-etc gnulib module.
+;;
+(define* (version-etc package version #:key
+ (port (current-output-port))
+ ;; FIXME: authors
+ (copyright-year 2011)
+ (copyright-holder "Free Software Foundation, Inc.")
+ (copyright (format #f "Copyright (C) ~a ~a"
+ copyright-year copyright-holder))
+ (license *GPLv3+*)
+ command-name
+ packager packager-version)
+ (if command-name
+ (format port "~a (~a) ~a\n" command-name package version)
+ (format port "~a ~a\n" package version))
+
+ (if packager
+ (if packager-version
+ (format port (_ "Packaged by ~a (~a)\n") packager packager-version)
+ (format port (_ "Packaged by ~a\n") packager)))
+
+ (display copyright port)
+ (newline port)
+ (newline port)
+ (display license port)
+ (newline port))
+
+
+;; Display the usual `Report bugs to' stanza.
+;;
+(define* (emit-bug-reporting-address package bug-address #:key
+ (port (current-output-port))
+ (url (string-append
+ "http://www.gnu.org/software/";
+ package
+ "/"))
+ packager packager-bug-address)
+ (format port (_ "\nReport bugs to: ~a\n") bug-address)
+ (if (and packager packager-bug-address)
+ (format port (_ "Report ~a bugs to: ~a\n") packager
packager-bug-address))
+ (format port (_ "~a home page: <~a>\n") package url)
+ (format port
+ (_ "General help using GNU software:
<http://www.gnu.org/gethelp/>\n")))
+
+(define *usage*
+ (_ "Evaluate Scheme code, interactively or from a script.
+
+ [-s] FILE load Scheme source code from FILE, and exit
+ -c EXPR evalute Scheme expression EXPR, and exit
+ -- stop scanning arguments; run interactively
+
+The above switches stop argument processing, and pass all
+remaining arguments as the value of (command-line).
+If FILE begins with `-' the -s switch is mandatory.
+
+ -L DIRECTORY add DIRECTORY to the front of the module load path
+ -x EXTENSION add EXTENSION to the front of the load extensions
+ -l FILE load Scheme source code from FILE
+ -e FUNCTION after reading script, apply FUNCTION to
+ command line arguments
+ -ds do -s script at this point
+ --debug start with debugging evaluator and backtraces
+ --no-debug start with normal evaluator
+ Default is to enable debugging for interactive
+ use, but not for `-s' and `-c'.
+ --auto-compile compile source files automatically
+ --no-auto-compile disable automatic source file compilation
+ Default is to enable auto-compilation of source
+ files.
+ --listen[=P] Listen on a local port or a path for REPL clients.
+ If P is not given, the default is local port 37146.
+ -q inhibit loading of user init file
+ --use-srfi=LS load SRFI modules for the SRFIs in LS,
+ which is a list of numbers like \"2,13,14\"
+ -h, --help display this help and exit
+ -v, --version display version information and exit
+ \\ read arguments from following script lines"))
+
+
+(define* (shell-usage name fatal? #:optional fmt . args)
+ (let ((port (if fatal?
+ (current-error-port)
+ (current-output-port))))
+ (if fmt
+ (apply format port fmt args))
+
+ (format port (_ "Usage: ~a [OPTION]... [FILE]...\n") name)
+ (display *usage* port)
+ (newline port)
+
+ (emit-bug-reporting-address
+ "GNU Guile" "address@hidden"
+ #:port port
+ #:url "http://www.gnu.org/software/guile/";
+ #:packager (assq-ref %guile-build-info 'packager)
+ #:packager-bug-address
+ (assq-ref %guile-build-info 'packager-bug-address))
+
+ (if fatal?
+ (exit 1))))
+
+(define (eval-string str)
+ (call-with-input-string
+ str
+ (lambda (port)
+ (let lp ()
+ (let ((exp (read port)))
+ (if (not (eof-object? exp))
+ (begin
+ (eval exp (current-module))
+ (lp))))))))
+
+(define* (compile-shell-switches args #:optional (usage-name "guile"))
+ (let ((arg0 "guile")
+ (do-script '())
+ (entry-point #f)
+ (user-load-path '())
+ (user-extensions '())
+ (interactive? #t)
+ (inhibit-user-init? #f)
+ (turn-on-debugging? #f)
+ (turn-off-debugging? #f))
+
+ (define (error fmt . args)
+ (apply shell-usage usage-name #t fmt args))
+
+ (define (parse args out)
+ (cond
+ ((null? args)
+ (finish args out))
+ (else
+ (let ((arg (car args))
+ (args (cdr args)))
+ (cond
+ ((not (string-prefix? "-" arg)) ; foo
+ ;; 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 (pair? do-script)
+ (set-car! do-script arg))
+ (set! arg0 arg)
+ (set! interactive? #f)
+ (finish args
+ (cons `(load ,arg) out)))
+
+ ((string=? arg "-s") ; foo
+ (if (null? args)
+ (error "missing argument to `-s' switch"))
+ (set! arg0 (car args))
+ (if (pair? do-script)
+ (set-car! do-script arg0))
+ (set! interactive? #f)
+ (finish (cdr args)
+ (cons `(load ,arg0) out)))
+
+ ((string=? arg "-c") ; evaluate expr
+ (if (null? args)
+ (error "missing argument to `-c' switch"))
+ (set! interactive? #f)
+ (finish (cdr args)
+ ;; Use our own eval-string to avoid loading (ice-9
+ ;; eval-string), which loads the compiler.
+ (cons `((@@ (ice-9 command-line) eval-string) ,(car args))
+ out)))
+
+ ((string=? arg "--") ; end args go interactive
+ (finish args out))
+
+ ((string=? arg "-l") ; load a file
+ (if (null? args)
+ (error "missing argument to `-l' switch"))
+ (parse (cdr args)
+ (cons `(load ,(car args)) out)))
+
+ ((string=? arg "-L") ; add to %load-path
+ (if (null? args)
+ (error "missing argument to `-L' switch"))
+ (set! user-load-path (cons (car args) user-load-path))
+ (parse (cdr args)
+ out))
+
+ ((string=? arg "-x") ; add to %load-extensions
+ (if (null? args)
+ (error "missing argument to `-L' switch"))
+ (set! user-extensions (cons (car args) user-extensions))
+ (parse (cdr args)
+ out))
+
+ ((string=? arg "-e") ; entry point
+ (if (null? args)
+ (error "missing argument to `-e' switch"))
+ (let* ((port (open-input-string (car args)))
+ (arg1 (read port))
+ (arg2 (read port)))
+ ;; Recognize syntax of certain versions of guile 1.4 and
+ ;; transform to (@ MODULE-NAME FUNC).
+ (set! entry-point
+ (cond
+ ((not (eof-object? arg2))
+ `(@ ,arg1 ,arg2))
+ ((and (pair? arg1)
+ (not (memq (car arg1) '(@ @@)))
+ (and-map symbol? arg1))
+ `(@ ,arg1 main))
+ (else
+ arg1))))
+ (parse (cdr args)
+ out))
+
+ ((string=? arg "-ds") ; do script here
+ ;; We put a dummy "load" expression, and let the -s put the
+ ;; filename in.
+ (if (pair? do-script)
+ (error "the -ds switch may only be specified once")
+ (set! do-script (list #f)))
+ (parse args
+ (cons `(load . ,do-script) out)))
+
+ ((string=? arg "--debug")
+ (set! turn-on-debugging? #t)
+ (set! turn-off-debugging? #f)
+ (parse args out))
+
+ ((string=? arg "--no-debug")
+ (set! turn-off-debugging? #t)
+ (set! turn-on-debugging? #f)
+ (parse args out))
+
+ ;; Do auto-compile on/off now, because the form itself might
+ ;; need this decision.
+ ((string=? arg "--auto-compile")
+ (set! %load-should-auto-compile #t))
+
+ ((string=? arg "--no-auto-compile")
+ (set! %load-should-auto-compile #f))
+
+ ((string=? arg "-q") ; don't load user init
+ (set! inhibit-user-init? #t))
+
+ ((string-prefix? "--use-srfi=" arg)
+ (let ((srfis (map (lambda (x)
+ (let ((n (string->number x)))
+ (if (and n (exact? n) (integer? n) (>= n 0))
+ n
+ (error "invalid SRFI specification"))))
+ (string-split (substring arg 11) #\,))))
+ (if (null? srfis)
+ (error "invalid SRFI specification"))
+ (parse args
+ (cons `(use-srfis ',srfis) out))))
+
+ ((string=? arg "--listen") ; start a repl server
+ (parse args
+ (cons '(@@ (system repl server) (spawn-server)) out)))
+
+ ((string-prefix? "--listen=" arg) ; start a repl server
+ (parse
+ args
+ (cons
+ (let ((where (substring arg 8)))
+ (cond
+ ((string->number where) ; --listen=PORT
+ => (lambda (port)
+ (if (and (integer? port) (exact? port) (>= port 0))
+ (error "invalid port for --listen")
+ `(@@ (system repl server)
+ (spawn-server
+ (make-tcp-server-socket #:port ,port))))))
+ ((string-prefix? "/" where) ; --listen=/PATH/TO/SOCKET
+ `(@@ (system repl server)
+ (spawn-server
+ (make-unix-domain-server-socket #:path ,where))))
+ (else
+ (error "unknown argument to --listen"))))
+ out)))
+
+ ((or (string=? arg "-h") (string=? arg "--help"))
+ (shell-usage usage-name #f)
+ (exit 0))
+
+ ((or (string=? arg "-v") (string=? arg "--version"))
+ (version-etc "GNU Guile" (version)
+ #:license *LGPLv3+*
+ #:command-name "guile"
+ #:packager (assq-ref %guile-build-info 'packager)
+ #:packager-version
+ (assq-ref %guile-build-info 'packager-version))
+ (exit 0))
+
+ (else
+ (error "Unrecognized switch ~a" arg)))))))
+
+ (define (finish args out)
+ ;; Check to make sure the -ds got a -s.
+ (if (and (pair? do-script) (not (car do-script)))
+ (error "the `-ds' switch requires the use of `-s' as well"))
+
+ ;; Make any remaining arguments available to the
+ ;; script/command/whatever.
+ (set-program-arguments (cons arg0 args))
+
+ ;; If debugging was requested, or we are interactive and debugging
+ ;; was not explicitly turned off, use the debug engine.
+ (if (or turn-on-debugging?
+ (and interactive? (not turn-off-debugging?)))
+ (begin
+ (set-default-vm-engine! 'debug)
+ (set-vm-engine! (the-vm) 'debug)))
+
+ ;; Return this value.
+ `(;; It would be nice not to load up (ice-9 control), but the
+ ;; default-prompt-handler is nontrivial.
+ (@ (ice-9 control) %)
+ (begin
+ ;; If we didn't end with a -c or a -s and didn't supply a -q, load
+ ;; the user's customization file.
+ ,@(if (and interactive? (not inhibit-user-init?))
+ '((load-user-init))
+ '())
+
+ ;; Use-specified extensions.
+ ,@(map (lambda (ext)
+ `(set! %load-extensions (cons ,ext %load-extensions)))
+ user-extensions)
+
+ ;; Add the user-specified load path here, so it won't be in
+ ;; effect during the loading of the user's customization file.
+ ,@(map (lambda (path)
+ `(set! %load-path (cons ,path %load-path)))
+ user-load-path)
+
+ ;; Put accumulated actions in their correct order.
+ ,@(reverse! out)
+
+ ;; Handle the `-e' switch, if it was specified.
+ ,@(if entry-point
+ `((,entry-point (command-line)))
+ '())
+ ,(if interactive?
+ ;; If we didn't end with a -c or a -s, start the
+ ;; repl.
+ '((@ (ice-9 top-repl) top-repl))
+ ;; Otherwise, after doing all the other actions
+ ;; prescribed by the command line, quit.
+ '(quit)))))
+
+ (if (pair? args)
+ (begin
+ (set! arg0 (car args))
+ (let ((slash (string-rindex arg0 #\/)))
+ (set! usage-name
+ (if slash (substring arg0 (1+ slash)) arg0)))
+ (parse (cdr args) '()))
+ (parse args '()))))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index 60a5bcd..61357f8 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -1343,6 +1343,27 @@ accurate information is missing from a given `tree-il'
element."
min-count max-count))))
(else (error "computer bought the farm" state))))))
+;; Return the literal format pattern for X, or #f.
+(define (const-fmt x)
+ (record-case x
+ ((<const> exp)
+ ;; String literals.
+ (and (string? exp) exp))
+ ((<application> proc args)
+ ;; Gettexted string literals, like `(_ "foo")'.
+ (and (record-case proc
+ ((<toplevel-ref> name) (eq? name '_))
+ ((<module-ref> name) (eq? name '_))
+ (else #f))
+ (pmatch args
+ ((,fmt)
+ (record-case fmt
+ ((<const> exp)
+ (and (string? exp) exp))
+ (else #f)))
+ (else #f))))
+ (else #f)))
+
(define format-analysis
;; Report arity mismatches in the given tree.
(make-tree-analysis
@@ -1355,11 +1376,11 @@ accurate information is missing from a given `tree-il'
element."
(define (check-format-args args loc)
(pmatch args
((,port ,fmt . ,rest)
- (guard (const? fmt))
+ (guard (const-fmt fmt))
(if (and (const? port)
(not (boolean? (const-exp port))))
(warning 'format loc 'wrong-port (const-exp port)))
- (let ((fmt (const-exp fmt))
+ (let ((fmt (const-fmt fmt))
(count (length rest)))
(if (string? fmt)
(catch &syntax-error
@@ -1375,6 +1396,9 @@ accurate information is missing from a given `tree-il'
element."
(warning 'format loc 'syntax-error key fmt)))
(warning 'format loc 'wrong-format-string fmt))))
((,port ,fmt . ,rest)
+ (if (and (const? port)
+ (not (boolean? (const-exp port))))
+ (warn 'format loc 'wrong-port (const-exp port)))
;; Warn on non-literal format strings, unless they refer to a
;; lexical variable named "fmt".
(if (record-case fmt
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.0-188-ge07f0a5,
Andy Wingo <=