-/* Copyright (C) 1995,1996,1997,1998,1999, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004 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.
+ * 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.
*
- * 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.
- *
- * 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
+ */
-/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
- gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
\f
/* Include the headers for just about everything.
We call all their initialization functions. */
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
#include <stdio.h>
#include <sys/stat.h>
#include <fcntl.h>
+#include <gmp.h>
#include "libguile/_scm.h"
#include "libguile/boolean.h"
#include "libguile/chars.h"
#include "libguile/continuations.h"
-#ifdef DEBUG_EXTENSIONS
#include "libguile/debug.h"
-#endif
#ifdef GUILE_DEBUG_MALLOC
#include "libguile/debug-malloc.h"
#endif
+#include "libguile/deprecation.h"
#include "libguile/dynl.h"
#include "libguile/dynwind.h"
+#include "libguile/environments.h"
#include "libguile/eq.h"
#include "libguile/error.h"
#include "libguile/eval.h"
#include "libguile/filesys.h"
#include "libguile/fluids.h"
#include "libguile/fports.h"
+#include "libguile/futures.h"
#include "libguile/gc.h"
#include "libguile/gdbint.h"
+#include "libguile/goops.h"
#include "libguile/gsubr.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
-#ifdef GUILE_ISELECT
+#include "libguile/hooks.h"
+#include "libguile/i18n.h"
#include "libguile/iselect.h"
-#endif
#include "libguile/ioext.h"
#include "libguile/keywords.h"
#include "libguile/lang.h"
#include "libguile/print.h"
#include "libguile/procprop.h"
#include "libguile/procs.h"
+#include "libguile/properties.h"
#include "libguile/ramap.h"
#include "libguile/random.h"
+#include "libguile/rdelim.h"
#include "libguile/read.h"
+#include "libguile/rw.h"
#include "libguile/scmsigs.h"
#include "libguile/script.h"
#include "libguile/simpos.h"
#include "libguile/stacks.h"
#include "libguile/stime.h"
#include "libguile/strings.h"
-#include "libguile/strop.h"
+#include "libguile/srfi-13.h"
+#include "libguile/srfi-14.h"
#include "libguile/strorder.h"
#include "libguile/strports.h"
#include "libguile/struct.h"
#include "libguile/symbols.h"
-#include "libguile/tag.h"
#include "libguile/throw.h"
#include "libguile/unif.h"
+#include "libguile/values.h"
#include "libguile/variable.h"
#include "libguile/vectors.h"
#include "libguile/version.h"
#include "libguile/vports.h"
#include "libguile/weaks.h"
#include "libguile/guardians.h"
+#include "libguile/extensions.h"
+#include "libguile/srfi-4.h"
+#include "libguile/discouraged.h"
+#include "libguile/deprecated.h"
#include "libguile/init.h"
#include <unistd.h>
#endif
\f
-/* Setting up the stack. */
-
-static void
-restart_stack (void *base)
-{
- scm_dynwinds = SCM_EOL;
- SCM_DYNENV (scm_rootcont) = SCM_EOL;
- SCM_THROW_VALUE (scm_rootcont) = SCM_EOL;
-#ifdef DEBUG_EXTENSIONS
- SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
-#endif
- SCM_BASE (scm_rootcont) = base;
- scm_continuation_stack_ptr = SCM_MAKINUM (0);
-}
-
-static void
-start_stack (void *base)
-{
- SCM root;
-
- root = scm_permanent_object (scm_make_root (SCM_UNDEFINED));
- scm_set_root (SCM_ROOT_STATE (root));
- scm_stack_base = base;
-
- scm_exitval = SCM_BOOL_F; /* vestigial */
-
- scm_top_level_lookup_closure_var = SCM_BOOL_F;
- scm_system_transformer = SCM_BOOL_F;
-
- scm_root->fluids = scm_make_initial_fluids ();
-
- /* Create an object to hold the root continuation.
- */
- SCM_NEWCELL (scm_rootcont);
- SCM_SET_CONTREGS (scm_rootcont, scm_must_malloc (sizeof (scm_contregs),
- "continuation"));
- SCM_SET_CELL_TYPE (scm_rootcont, scm_tc7_contin);
- SCM_SEQ (scm_rootcont) = 0;
- /* The root continuation if further initialized by restart_stack. */
-
- /* Create the look-aside stack for variables that are shared between
- * captured continuations.
- */
- scm_continuation_stack = scm_make_vector (SCM_MAKINUM (512), SCM_UNDEFINED);
- /* The continuation stack is further initialized by restart_stack. */
-
- /* The remainder of stack initialization is factored out to another
- * function so that if this stack is ever exitted, it can be
- * re-entered using restart_stack. */
- restart_stack (base);
-}
#if 0
static void
-fixconfig (char *s1,char *s2,int s)
+fixconfig (char *s1, char *s2, int s)
{
fputs (s1, stderr);
fputs (s2, stderr);
static void
check_config (void)
{
- scm_sizet j;
+ size_t j;
j = HEAP_SEG_SIZE;
if (HEAP_SEG_SIZE != j)
fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);
-#ifdef SCM_BIGDIG
- if (2 * SCM_BITSPERDIG / SCM_CHAR_BIT > sizeof (long))
- fixconfig (remsg, "SCM_BIGDIG", 0);
-#ifndef SCM_DIGSTOOBIG
- if (SCM_DIGSPERLONG * sizeof (SCM_BIGDIG) > sizeof (long))
- fixconfig (addmsg, "SCM_DIGSTOOBIG", 0);
-#endif
-#endif
-
-#ifdef SCM_STACK_GROWS_UP
+#if SCM_STACK_GROWS_UP
if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0)
fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
#else
{
stream_body_data *body_data = (stream_body_data *) data;
SCM port = scm_fdes_to_port (body_data->fdes, body_data->mode,
- scm_makfrom0str (body_data->name));
+ scm_from_locale_string (body_data->name));
SCM_REVEALED (port) = 1;
return port;
/* exception handler for stream_body. */
static SCM
-stream_handler (void *data, SCM tag, SCM throw_args)
+stream_handler (void *data SCM_UNUSED,
+ SCM tag SCM_UNUSED,
+ SCM throw_args SCM_UNUSED)
{
return SCM_BOOL_F;
}
body_data.name = name;
port = scm_internal_catch (SCM_BOOL_T, stream_body, &body_data,
stream_handler, NULL);
- if (SCM_FALSEP (port))
+ if (scm_is_false (port))
port = scm_void_port (mode);
return port;
}
buffered input on stdin can reset \ex{(current-input-port)} to
block buffering for higher performance. */
- scm_def_inp
- = scm_standard_stream_to_port (0,
- isatty (0) ? "r0" : "r",
- "standard input");
- scm_def_outp = scm_standard_stream_to_port (1,
- isatty (1) ? "w0" : "w",
- "standard output");
- scm_def_errp = scm_standard_stream_to_port (2,
- isatty (2) ? "w0" : "w",
- "standard error");
-
- scm_cur_inp = scm_def_inp;
- scm_cur_outp = scm_def_outp;
- scm_cur_errp = scm_def_errp;
- scm_cur_loadp = SCM_BOOL_F;
+ scm_set_current_input_port
+ (scm_standard_stream_to_port (0,
+ isatty (0) ? "r0" : "r",
+ "standard input"));
+ scm_set_current_output_port
+ (scm_standard_stream_to_port (1,
+ isatty (1) ? "w0" : "w",
+ "standard output"));
+ scm_set_current_error_port
+ (scm_standard_stream_to_port (2,
+ isatty (2) ? "w0" : "w",
+ "standard error"));
}
/* We want a path only containing directories from GUILE_LOAD_PATH,
SCM_SITE_DIR and SCM_LIBRARY_DIR when searching for the site init
file, so we do this before loading Ice-9. */
- SCM init_path = scm_sys_search_load_path (scm_makfrom0str ("init.scm"));
+ SCM init_path =
+ scm_sys_search_load_path (scm_from_locale_string ("init.scm"));
/* Load Ice-9. */
if (!scm_ice_9_already_loaded)
{
- scm_primitive_load_path (scm_makfrom0str ("ice-9/boot-9.scm"));
+ scm_primitive_load_path (scm_from_locale_string ("ice-9/boot-9.scm"));
/* Load the init.scm file. */
- if (SCM_NFALSEP (init_path))
+ if (scm_is_true (init_path))
scm_primitive_load (init_path);
-
- scm_post_boot_init_modules ();
}
}
-#ifdef GUILE_NEW_GC_SCHEME
-/* Get an integer from an environment variable. */
-static int
-scm_i_getenv_int (const char *var, int def)
-{
- char *end, *val = getenv (var);
- long res;
- if (!val)
- return def;
- res = strtol (val, &end, 10);
- if (end == val)
- return def;
- return res;
-}
-#endif /* GUILE_DEBUG */
-
\f
/* The main init code. */
char **argv; /* the argument list it should receive */
};
-
-static void scm_boot_guile_1(SCM_STACKITEM *base, struct main_func_closure *closure);
-static SCM invoke_main_func(void *body_data);
+static void *invoke_main_func(void *body_data);
/* Fire up the Guile Scheme interpreter.
void
scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure)
{
- /* The garbage collector uses the address of this variable as one
- end of the stack, and the address of one of its own local
- variables as the other end. */
- SCM_STACKITEM dummy;
struct main_func_closure c;
c.main_func = main_func;
c.argc = argc;
c.argv = argv;
- scm_boot_guile_1 (&dummy, &c);
+ scm_with_guile (invoke_main_func, &c);
}
+static void *
+invoke_main_func (void *body_data)
+{
+ struct main_func_closure *closure = (struct main_func_closure *) body_data;
+
+ scm_set_program_arguments (closure->argc, closure->argv, 0);
+ (*closure->main_func) (closure->closure, closure->argc, closure->argv);
-/* Record here whether SCM_BOOT_GUILE_1 has already been called. This
- variable is now here and not inside SCM_BOOT_GUILE_1 so that one
- can tweak it. This is necessary for unexec to work. (Hey, "1-live"
- is the name of a local radiostation...) */
+ scm_restore_signals ();
-int scm_boot_guile_1_live = 0;
+ /* This tick gives any pending
+ * asyncs a chance to run. This must be done after
+ * the call to scm_restore_signals.
+ */
+ SCM_ASYNC_TICK;
-static void
-scm_boot_guile_1 (SCM_STACKITEM *base, struct main_func_closure *closure)
+ /* If the caller doesn't want this, they should exit from main_func
+ themselves.
+ */
+ exit (0);
+
+ /* never reached */
+ return NULL;
+}
+
+scm_i_pthread_mutex_t scm_i_init_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
+int scm_initialized_p = 0;
+
+static void *
+really_cleanup_for_exit (void *unused)
{
- static int initialized = 0;
- /* static int live = 0; */
- setjmp_type setjmp_val;
+ scm_flush_all_ports ();
+ return NULL;
+}
- /* This function is not re-entrant. */
- if (scm_boot_guile_1_live)
- abort ();
+static void
+cleanup_for_exit ()
+{
+ /* This function might be called in non-guile mode, so we need to
+ enter it temporarily.
+ */
+ scm_with_guile (really_cleanup_for_exit, NULL);
+}
- scm_boot_guile_1_live = 1;
+void
+scm_i_init_guile (SCM_STACKITEM *base)
+{
+ if (scm_initialized_p)
+ return;
- scm_ints_disabled = 1;
- scm_block_gc = 1;
-
- if (initialized)
+ if (base == NULL)
{
- restart_stack (base);
+ fprintf (stderr, "cannot determine stack base!\n");
+ abort ();
}
- else
+
+ if (sizeof (mpz_t) > (3 * sizeof (scm_t_bits)))
{
- scm_ports_prehistory ();
- scm_smob_prehistory ();
- scm_tables_prehistory ();
+ fprintf (stderr,
+ "GMP's mpz_t must fit into a double_cell,"
+ "but doesn't seem to here.\n");
+ }
+
+ scm_storage_prehistory ();
+ scm_threads_prehistory (base);
+ scm_ports_prehistory ();
+ scm_smob_prehistory ();
+ scm_fluids_prehistory ();
+ scm_hashtab_prehistory (); /* requires storage_prehistory */
#ifdef GUILE_DEBUG_MALLOC
- scm_debug_malloc_prehistory ();
-#endif
-#if defined (GUILE_NEW_GC_SCHEME)
- scm_init_storage (scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", 0),
- scm_i_getenv_int ("GUILE_MIN_YIELD_1", 0),
- scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", 0),
- scm_i_getenv_int ("GUILE_MIN_YIELD_2", 0),
- scm_i_getenv_int ("GUILE_MAX_SEGMENT_SIZE", 0));
-#else
- scm_init_storage (0, 0);
-#endif
- scm_init_subr_table ();
- scm_init_root ();
-#ifdef USE_THREADS
- scm_init_threads (base);
+ scm_debug_malloc_prehistory ();
#endif
- start_stack (base);
- scm_init_gsubr ();
- scm_init_feature ();
- scm_init_alist ();
- scm_init_arbiters ();
- scm_init_async ();
- scm_init_boolean ();
- scm_init_chars ();
- scm_init_continuations ();
+ if (scm_init_storage ()) /* requires threads_prehistory,
+ smob_prehistory and
+ hashtab_prehistory */
+ abort ();
+
+ scm_struct_prehistory (); /* requires storage */
+ scm_symbols_prehistory (); /* requires storage */
+ scm_weaks_prehistory (); /* requires storage */
+ scm_init_subr_table ();
+ scm_environments_prehistory (); /* requires storage */
+ scm_modules_prehistory (); /* requires storage and hash tables */
+ scm_init_variable (); /* all bindings need variables */
+ scm_init_continuations ();
+ scm_init_root (); /* requires continuations */
+ scm_init_threads (); /* requires fluids */
+ scm_init_gsubr ();
+ scm_init_thread_procs (); /* requires gsubrs */
+ scm_init_procprop ();
+ scm_init_environments ();
+ scm_init_alist ();
+ scm_init_arbiters ();
+ scm_init_async ();
+ scm_init_boolean ();
+ scm_init_chars ();
#ifdef GUILE_DEBUG_MALLOC
- scm_init_debug_malloc ();
-#endif
- scm_init_dynwind ();
- scm_init_eq ();
- scm_init_error ();
- scm_init_fluids ();
- scm_init_backtrace (); /* Requires fluids */
- scm_init_fports ();
- scm_init_gc ();
- scm_init_gdbint ();
- scm_init_hash ();
- scm_init_hashtab ();
-#ifdef GUILE_ISELECT
- scm_init_iselect ();
+ scm_init_debug_malloc ();
#endif
- scm_init_ioext ();
- scm_init_keywords ();
- scm_init_list ();
- scm_init_macros ();
- scm_init_mallocs ();
- scm_init_modules ();
- scm_init_numbers ();
- scm_init_objprop ();
- scm_init_options ();
- scm_init_pairs ();
- scm_init_ports ();
+ scm_init_dynwind ();
+ scm_init_eq ();
+ scm_init_error ();
+ scm_init_futures ();
+ scm_init_fluids ();
+ scm_init_feature (); /* Requires fluids */
+ scm_init_backtrace (); /* Requires fluids */
+ scm_init_fports ();
+ scm_init_strports ();
+ scm_init_gdbint (); /* Requires strports */
+ scm_init_hash ();
+ scm_init_hashtab ();
+ scm_init_deprecation (); /* Requires hashtabs */
+ scm_init_objprop ();
+ scm_init_properties ();
+ scm_init_hooks (); /* Requires smob_prehistory */
+ scm_init_gc (); /* Requires hooks, async */
+ scm_init_i18n ();
+ scm_init_ioext ();
+ scm_init_keywords ();
+ scm_init_list ();
+ scm_init_macros ();
+ scm_init_mallocs ();
+ scm_init_modules ();
+ scm_init_numbers ();
+ scm_init_options ();
+ scm_init_pairs ();
+ scm_init_ports ();
#ifdef HAVE_POSIX
- scm_init_filesys ();
- scm_init_posix ();
+ scm_init_filesys ();
+ scm_init_posix ();
#endif
#ifdef HAVE_REGCOMP
- scm_init_regex_posix ();
+ scm_init_regex_posix ();
#endif
- scm_init_procs ();
- scm_init_procprop ();
- scm_init_scmsigs ();
+ scm_init_procs ();
+ scm_init_scmsigs ();
#ifdef HAVE_NETWORKING
- scm_init_net_db ();
- scm_init_socket ();
+ scm_init_net_db ();
+ scm_init_socket ();
#endif
- scm_init_sort ();
-#ifdef DEBUG_EXTENSIONS
- scm_init_srcprop ();
+ scm_init_sort ();
+ scm_init_srcprop ();
+ scm_init_stackchk ();
+ scm_init_strings ();
+ scm_init_struct (); /* Requires strings */
+ scm_init_stacks (); /* Requires strings, struct */
+ scm_init_symbols ();
+ scm_init_values (); /* Requires struct */
+ scm_init_load (); /* Requires strings */
+ scm_init_objects (); /* Requires struct */
+ scm_init_print (); /* Requires strings, struct */
+ scm_init_read ();
+ scm_init_stime ();
+ scm_init_strorder ();
+ scm_init_srfi_13 ();
+ scm_init_srfi_14 ();
+ scm_init_throw ();
+ scm_init_vectors ();
+ scm_init_version ();
+ scm_init_weaks ();
+ scm_init_guardians ();
+ scm_init_vports ();
+ scm_init_eval ();
+ scm_init_evalext ();
+ scm_init_debug (); /* Requires macro smobs */
+ scm_init_random ();
+ scm_init_ramap ();
+ scm_init_unif ();
+ scm_init_simpos ();
+ scm_init_load_path ();
+ scm_init_standard_ports (); /* Requires fports */
+ scm_init_dynamic_linking ();
+#if SCM_ENABLE_ELISP
+ scm_init_lang ();
+#endif /* SCM_ENABLE_ELISP */
+ scm_init_script ();
+ scm_init_srfi_4 ();
+
+ scm_init_goops ();
+
+#if SCM_ENABLE_DISCOURAGED == 1
+ scm_i_init_discouraged ();
#endif
- scm_init_stackchk ();
- scm_init_struct (); /* Requires struct */
- scm_init_stacks ();
- scm_init_strports ();
- scm_init_symbols ();
- scm_init_tag ();
- scm_init_load ();
- scm_init_objects (); /* Requires struct */
- scm_init_print (); /* Requires struct */
- scm_init_read ();
- scm_init_stime ();
- scm_init_strings ();
- scm_init_strorder ();
- scm_init_strop ();
- scm_init_throw ();
- scm_init_variable ();
- scm_init_vectors ();
- scm_init_version ();
- scm_init_weaks ();
- scm_init_guardian ();
- scm_init_vports ();
- scm_init_eval ();
- scm_init_evalext ();
-#ifdef DEBUG_EXTENSIONS
- scm_init_debug (); /* Requires macro smobs */
-#endif
- scm_init_random ();
-#ifdef HAVE_ARRAYS
- scm_init_ramap ();
- scm_init_unif ();
+
+#if SCM_ENABLE_DEPRECATED == 1
+ scm_i_init_deprecated ();
#endif
- scm_init_simpos ();
- scm_init_load_path ();
- scm_init_standard_ports ();
- scm_init_dynamic_linking ();
- scm_init_lang ();
- scm_init_script ();
- initialized = 1;
- }
- scm_block_gc = 0; /* permit the gc to run */
- /* ints still disabled */
+ scm_init_threads_default_dynamic_state ();
+
+ scm_initialized_p = 1;
#ifdef STACK_CHECKING
scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
#endif
- setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont));
- if (!setjmp_val)
- {
- scm_set_program_arguments (closure->argc, closure->argv, 0);
- scm_internal_lazy_catch (SCM_BOOL_T, invoke_main_func, closure,
- scm_handle_by_message, 0);
- }
-
- scm_restore_signals ();
-
- /* This tick gives any pending
- * asyncs a chance to run. This must be done after
- * the call to scm_restore_signals.
- */
- SCM_ASYNC_TICK;
-
- /* If the caller doesn't want this, they should return from
- main_func themselves. */
- exit (0);
-}
-
-
-static SCM
-invoke_main_func (void *body_data)
-{
- struct main_func_closure *closure = (struct main_func_closure *) body_data;
+ scm_init_rdelim ();
+ scm_init_rw ();
+ scm_init_extensions ();
+ atexit (cleanup_for_exit);
scm_load_startup_files ();
-
- (*closure->main_func) (closure->closure, closure->argc, closure->argv);
-
- /* never reached */
- return SCM_UNDEFINED;
}
/*
HCoop / bpt / guile.git / blobdiff