-/* Copyright (C) 1995,1996 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, 675 Mass Ave, Cambridge, MA 02139, 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.
- *
- * 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.
- *
- * 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.
- */
-\f
-
-#include <stdio.h>
-#include "_scm.h"
-
-/* Everybody has an init function. */
-#include "alist.h"
-#include "append.h"
-#include "arbiters.h"
-#include "async.h"
-#include "backtrace.h"
-#include "boolean.h"
-#include "chars.h"
-#include "continuations.h"
-#ifdef DEBUG_EXTENSIONS
-#include "debug.h"
-#endif
-#include "dynwind.h"
-#include "eq.h"
-#include "error.h"
-#include "eval.h"
-#include "fdsocket.h"
-#include "feature.h"
-#include "filesys.h"
-#include "fports.h"
-#include "gc.h"
-#include "gdbint.h"
-#include "gsubr.h"
-#include "hash.h"
-#include "hashtab.h"
-#include "ioext.h"
-#include "kw.h"
-#include "list.h"
-#include "load.h"
-#include "mallocs.h"
-#include "mbstrings.h"
-#include "numbers.h"
-#include "objprop.h"
-#include "options.h"
-#include "pairs.h"
-#include "ports.h"
-#include "posix.h"
-#include "print.h"
-#include "procprop.h"
-#include "procs.h"
-#include "ramap.h"
-#include "read.h"
-#include "scmsigs.h"
-#include "sequences.h"
-#include "simpos.h"
-#include "smob.h"
-#include "socket.h"
-#include "srcprop.h"
-#include "stackchk.h"
-#include "stacks.h"
-#include "stime.h"
-#include "strings.h"
-#include "strop.h"
-#include "strorder.h"
-#include "strports.h"
-#include "struct.h"
-#include "symbols.h"
-#include "tag.h"
-#include "throw.h"
-#include "unif.h"
-#include "variable.h"
-#include "vectors.h"
-#include "version.h"
-#include "vports.h"
-#include "weaks.h"
-
-#include "init.h"
-
-#ifdef HAVE_STRING_H
-#include <string.h>
-#endif
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-\f
-
-void
-scm_start_stack (base, in, out, err)
- void * base;
- FILE * in;
- FILE * out;
- FILE * err;
-{
- SCM root;
- struct scm_port_table * pt;
-
- root = scm_permanent_object (scm_make_root (SCM_UNDEFINED));
- scm_set_root (SCM_ROOT_STATE (root));
-
- scm_stack_base = base;
-
- /* Create standard ports from stdio files, if requested to do so.
- */
-
- if (!in)
- {
- scm_def_inp = SCM_BOOL_F;
- }
- else
- {
- SCM_NEWCELL (scm_def_inp);
- pt = scm_add_to_port_table (scm_def_inp);
- SCM_SETCAR (scm_def_inp, (scm_tc16_fport | SCM_OPN | SCM_RDNG));
- SCM_SETPTAB_ENTRY (scm_def_inp, pt);
- SCM_SETSTREAM (scm_def_inp, (SCM)in);
- if (isatty (fileno (in)))
- {
- scm_setbuf0 (scm_def_inp); /* turn off stdin buffering */
- SCM_SETOR_CAR (scm_def_inp, SCM_BUF0);
- }
- scm_set_port_revealed_x (scm_def_inp, SCM_MAKINUM (1));
- }
-
- if (!out)
- {
- scm_def_outp = SCM_BOOL_F;
- }
- else
- {
- SCM_NEWCELL (scm_def_outp);
- pt = scm_add_to_port_table (scm_def_outp);
- SCM_SETCAR (scm_def_outp, (scm_tc16_fport | SCM_OPN | SCM_WRTNG));
- SCM_SETPTAB_ENTRY (scm_def_outp, pt);
- SCM_SETSTREAM (scm_def_outp, (SCM)out);
- scm_set_port_revealed_x (scm_def_outp, SCM_MAKINUM (1));
- }
-
- if (!err)
- {
- scm_def_errp = SCM_BOOL_F;
- }
- else
- {
- SCM_NEWCELL (scm_def_errp);
- pt = scm_add_to_port_table (scm_def_errp);
- SCM_SETCAR (scm_def_errp, (scm_tc16_fport | SCM_OPN | SCM_WRTNG));
- SCM_SETPTAB_ENTRY (scm_def_errp, pt);
- SCM_SETSTREAM (scm_def_errp, (SCM)err);
- scm_set_port_revealed_x (scm_def_errp, SCM_MAKINUM (1));
- }
-
- scm_cur_inp = scm_def_inp;
- scm_cur_outp = scm_def_outp;
- scm_cur_errp = scm_def_errp;
-
-
- scm_progargs = SCM_BOOL_F; /* vestigial */
- scm_exitval = SCM_BOOL_F; /* vestigial */
-
- scm_top_level_lookup_thunk_var = SCM_BOOL_F;
- scm_system_transformer = SCM_BOOL_F;
-
- /* Create an object to hold the root continuation.
- */
- SCM_NEWCELL (scm_rootcont);
- SCM_SETJMPBUF (scm_rootcont, scm_must_malloc ((long) sizeof (scm_contregs), "continuation"));
- SCM_SETCAR (scm_rootcont, scm_tc7_contin);
- SCM_SEQ (scm_rootcont) = 0;
- /* The root continuation if further initialized by scm_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, SCM_UNDEFINED);
- /* The continuation stack is further initialized by scm_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 scm_restart_stack.
- */
- scm_restart_stack (base);
-}
-
-
-void
-scm_restart_stack (base)
- 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);
-}
-
-#if 0
-static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
-
-
-static void fixconfig SCM_P ((char *s1, char *s2, int s));
-
-static void
-fixconfig (s1, s2, s)
- char *s1;
- char *s2;
- int s;
-{
- fputs (s1, stderr);
- fputs (s2, stderr);
- fputs ("\nin ", stderr);
- fputs (s ? "setjump" : "scmfig", stderr);
- fputs (".h and recompile scm\n", stderr);
- exit (1);
-}
-
-
-static void check_config SCM_P ((void));
-
-static void
-check_config ()
-{
- scm_sizet j;
-
- j = HEAP_SEG_SIZE;
- if (HEAP_SEG_SIZE != j)
- fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);
-
-#ifdef SCM_SINGLES
- if (sizeof (float) != sizeof (long))
- fixconfig (remsg, "SCM_SINGLES", 0);
-#endif /* def SCM_SINGLES */
-
-
-#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_STACKITEM *) & j - stack_start_ptr) < 0)
- fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
-#else
- if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0)
- fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1);
-#endif
-}
-#endif
-
-
-\f
-#ifdef _UNICOS
-typedef int setjmp_type;
-#else
-typedef long setjmp_type;
-#endif
-
-/* Fire up Scheme.
- *
- * argc and argv are made the return values of program-arguments.
- *
- * in, out, and err, if not NULL, become the standard ports.
- * If NULL is passed, your "initfunc" should set up the
- * standard ports.
- *
- * boot_cmd is a string containing a Scheme expression to evaluate
- * to get things rolling.
- *
- * result is returned a string containing a printed result of evaluating
- * the boot command.
- *
- * the return value is:
- * scm_boot_ok - evaluation concluded normally
- * scm_boot_error - evaluation concluded with a Scheme error
- * scm_boot_emem - allocation error mallocing *result
- * scm_boot_ereenter - scm_boot_guile was called re-entrantly, which is
- * prohibited.
- */
-
-int scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base,
- char **result,
- int argc, char **argv,
- FILE *in, FILE *out, FILE *err,
- void (*init_func) (),
- char *boot_cmd));
-
-int
-scm_boot_guile (result, argc, argv, in, out, err, init_func, boot_cmd)
- char ** result;
- int argc;
- char ** argv;
- FILE * in;
- FILE * out;
- FILE * err;
- void (*init_func) ();
- char * boot_cmd;
-{
- SCM_STACKITEM dummy;
-
- return scm_boot_guile_1 (&dummy, result, argc, argv, in, out, err,
- init_func, boot_cmd);
-}
-
-int
-scm_boot_guile_1 (base, result, argc, argv, in, out, err, init_func, boot_cmd)
- SCM_STACKITEM *base;
- char ** result;
- int argc;
- char ** argv;
- FILE * in;
- FILE * out;
- FILE * err;
- void (*init_func) ();
- char * boot_cmd;
-{
- static int initialized = 0;
- static int live = 0;
- setjmp_type setjmp_val;
- int stat;
-
- if (live) /* This function is not re-entrant. */
- {
- return scm_boot_ereenter;
- }
-
- live = 1;
-
- scm_ints_disabled = 1;
- scm_block_gc = 1;
-
- if (initialized)
- {
- scm_restart_stack (base);
- }
- else
- {
- scm_ports_prehistory ();
- scm_smob_prehistory ();
- scm_tables_prehistory ();
- scm_init_storage (0);
- scm_init_root ();
-#ifdef USE_THREADS
- scm_init_threads (base);
-#endif
- scm_start_stack (base, in, out, err);
- scm_init_gsubr ();
- scm_init_feature ();
- scm_init_alist ();
- scm_init_append ();
- scm_init_arbiters ();
- scm_init_async ();
- scm_init_backtrace ();
- scm_init_boolean ();
- scm_init_chars ();
- scm_init_continuations ();
- scm_init_dynwind ();
- scm_init_eq ();
- scm_init_error ();
- scm_init_fdsocket ();
- scm_init_fports ();
- scm_init_filesys ();
- scm_init_gc ();
- scm_init_gdbint ();
- scm_init_hash ();
- scm_init_hashtab ();
- scm_init_ioext ();
- scm_init_kw ();
- scm_init_list ();
- scm_init_mallocs ();
- scm_init_numbers ();
- scm_init_objprop ();
-#if DEBUG_EXTENSIONS
- /* Excluding this until it's really needed makes the binary
- * smaller after linking. */
- scm_init_options ();
-#endif
- scm_init_pairs ();
- scm_init_ports ();
- scm_init_posix ();
- scm_init_procs ();
- scm_init_procprop ();
- scm_init_scmsigs ();
- scm_init_socket ();
-#ifdef DEBUG_EXTENSIONS
- scm_init_srcprop ();
-#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_print (); /* Requires struct */
- scm_init_read ();
- scm_init_sequences ();
- scm_init_stime ();
- scm_init_strings ();
- scm_init_strorder ();
- scm_init_mbstrings ();
- scm_init_strop ();
- scm_init_throw ();
- scm_init_variable ();
- scm_init_vectors ();
- scm_init_version ();
- scm_init_weaks ();
- scm_init_vports ();
- scm_init_eval ();
-#ifdef DEBUG_EXTENSIONS
- scm_init_debug (); /* Requires macro smobs */
-#endif
- scm_init_ramap ();
- scm_init_unif ();
- scm_init_simpos ();
- scm_progargs = scm_makfromstrs (argc, argv);
- scm_init_load_path ();
- initialized = 1;
- }
-
- scm_block_gc = 0; /* permit the gc to run */
- /* ints still disabled */
-
- {
- SCM command;
-
- command = scm_makfrom0str (boot_cmd);
-
- setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont));
-
-#ifdef STACK_CHECKING
- scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
-#endif
- if (!setjmp_val)
- {
- SCM last = SCM_UNDEFINED;
- scm_init_signals ();
-
- /* Call the initialization function passed in by the user, if
- present. */
- if (init_func) (*init_func) ();
-
- /* Evaluate boot_cmd string. */
- {
- SCM p;
- SCM form;
-
- p = scm_mkstrport (SCM_MAKINUM (0),
- command,
- SCM_OPN | SCM_RDNG,
- "boot_guile");
- while (1)
- {
- form = scm_read (p, SCM_BOOL_F, SCM_BOOL_F);
- if (SCM_EOF_VAL == form)
- break;
- last = scm_eval_x (form);
- }
-
- }
-
- 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;
-
- scm_ints_disabled = 1; /* Hopefully redundant but just to be sure. */
-
- {
- SCM str_answer;
-
- str_answer = scm_strprint_obj (last);
- *result = (char *)malloc (1 + SCM_LENGTH (str_answer));
- if (!*result)
- stat = scm_boot_emem;
- else
- {
- memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer));
- (*result)[SCM_LENGTH (str_answer)] = 0;
- stat = scm_boot_ok;
- }
- }
- }
- else
- {
- /* This is reached if an unhandled throw terminated Scheme.
- * Such an occurence should be extremely unlikely -- it indicates
- * a programming error in the boot code.
- *
- * Details of the bogus exception are stored in scm_exitval even
- * though that isn't currently reflected in the return value.
- * !!!
- */
-
- scm_restore_signals ();
- /* This tick gives any pending
- * asyncs a chance to run. This must be done after
- * the call to scm_restore_signals.
- *
- * Note that an unhandled exception during signal handling
- * will put as back at the call to scm_restore_signals immediately
- * preceeding. A sufficiently bogus signal handler could
- * conceivably cause an infinite loop here.
- */
- SCM_ASYNC_TICK;
-
- scm_ints_disabled = 1; /* Hopefully redundant but just to be sure. */
-
- {
- SCM str_answer;
-
- str_answer = scm_strprint_obj (scm_exitval);
- *result = (char *)malloc (1 + SCM_LENGTH (str_answer));
- if (!*result)
- stat = scm_boot_emem;
- else
- {
- memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer));
- (*result)[SCM_LENGTH (str_answer)] = 0;
- stat = scm_boot_error;
- }
- }
- }
- }
-
- scm_block_gc = 1;
- live = 0;
- return stat;
-}
+/* Copyright (C) 1995,1996,1997,1998,1999, 2000 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.
+ *
+ * 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.
+ *
+ * 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. */
+
+/* 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. */
+
+#include <stdio.h>
+#include <sys/stat.h>
+#include <fcntl.h>
+
+#include "libguile/_scm.h"
+
+/* Everybody has an init function. */
+#include "libguile/alist.h"
+#include "libguile/arbiters.h"
+#include "libguile/async.h"
+#include "libguile/backtrace.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/dynl.h"
+#include "libguile/dynwind.h"
+#include "libguile/environments.h"
+#include "libguile/eq.h"
+#include "libguile/error.h"
+#include "libguile/eval.h"
+#include "libguile/evalext.h"
+#include "libguile/feature.h"
+#include "libguile/filesys.h"
+#include "libguile/fluids.h"
+#include "libguile/fports.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"
+#include "libguile/hooks.h"
+#ifdef GUILE_ISELECT
+#include "libguile/iselect.h"
+#endif
+#include "libguile/ioext.h"
+#include "libguile/keywords.h"
+#include "libguile/lang.h"
+#include "libguile/list.h"
+#include "libguile/load.h"
+#include "libguile/macros.h"
+#include "libguile/mallocs.h"
+#include "libguile/modules.h"
+#include "libguile/net_db.h"
+#include "libguile/numbers.h"
+#include "libguile/objects.h"
+#include "libguile/objprop.h"
+#include "libguile/options.h"
+#include "libguile/pairs.h"
+#include "libguile/ports.h"
+#include "libguile/posix.h"
+#ifdef HAVE_REGCOMP
+#include "libguile/regex-posix.h"
+#endif
+#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/read.h"
+#include "libguile/scmsigs.h"
+#include "libguile/script.h"
+#include "libguile/simpos.h"
+#include "libguile/smob.h"
+#include "libguile/socket.h"
+#include "libguile/sort.h"
+#include "libguile/srcprop.h"
+#include "libguile/stackchk.h"
+#include "libguile/stacks.h"
+#include "libguile/stime.h"
+#include "libguile/strings.h"
+#include "libguile/strop.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/init.h"
+
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+#ifdef HAVE_UNISTD_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 */
+
+#if SCM_DEBUG_DEPRECATED == 0
+ scm_top_level_lookup_closure_var = SCM_BOOL_F;
+#endif
+ scm_system_transformer = SCM_BOOL_F;
+
+ scm_root->fluids = scm_make_initial_fluids ();
+
+ /* Create an object to hold the root continuation.
+ */
+ {
+ scm_contregs *contregs = scm_must_malloc (sizeof (scm_contregs),
+ "continuation");
+ contregs->num_stack_items = 0;
+ contregs->seq = 0;
+ SCM_NEWSMOB (scm_rootcont, scm_tc16_continuation, contregs);
+ }
+ /* The root continuation is 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 char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
+
+
+static void
+fixconfig (char *s1,char *s2,int s)
+{
+ fputs (s1, stderr);
+ fputs (s2, stderr);
+ fputs ("\nin ", stderr);
+ fputs (s ? "setjump" : "scmfig", stderr);
+ fputs (".h and recompile scm\n", stderr);
+ exit (1);
+}
+
+
+static void
+check_config (void)
+{
+ scm_sizet 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_STACKITEM *) & j - stack_start_ptr) < 0)
+ fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
+#else
+ if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0)
+ fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1);
+#endif
+}
+#endif
+
+
+\f
+/* initializing standard and current I/O ports */
+
+typedef struct
+{
+ int fdes;
+ char *mode;
+ char *name;
+} stream_body_data;
+
+/* proc to be called in scope of exception handler stream_handler. */
+static SCM
+stream_body (void *data)
+{
+ 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_REVEALED (port) = 1;
+ return port;
+}
+
+/* exception handler for stream_body. */
+static SCM
+stream_handler (void *data, SCM tag, SCM throw_args)
+{
+ return SCM_BOOL_F;
+}
+
+/* Convert a file descriptor to a port, using scm_fdes_to_port.
+ - NAME is a C string, not a Guile string
+ - set the revealed count for FILE's file descriptor to 1, so
+ that fdes won't be closed when the port object is GC'd.
+ - catch exceptions: allow Guile to be able to start up even
+ if it has been handed bogus stdin/stdout/stderr. replace the
+ bad ports with void ports. */
+static SCM
+scm_standard_stream_to_port (int fdes, char *mode, char *name)
+{
+ SCM port;
+ stream_body_data body_data;
+
+ body_data.fdes = fdes;
+ body_data.mode = mode;
+ body_data.name = name;
+ port = scm_internal_catch (SCM_BOOL_T, stream_body, &body_data,
+ stream_handler, NULL);
+ if (SCM_FALSEP (port))
+ port = scm_void_port (mode);
+ return port;
+}
+
+/* Create standard ports from stdin, stdout, and stderr. */
+static void
+scm_init_standard_ports ()
+{
+ /* From the SCSH manual:
+
+ It can be useful to turn I/O buffering off in some cases, for
+ example when an I/O stream is to be shared by multiple
+ subprocesses. For this reason, scsh allocates an unbuffered port
+ for file descriptor 0 at start-up time.
+
+ Because shells frequently share stdin with subprocesses, if the
+ shell does buffered reads, it might ``steal'' input intended for
+ a subprocess. For this reason, all shells, including sh, csh,
+ and scsh, read stdin unbuffered. Applications that can tolerate
+ 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;
+}
+
+
+\f
+/* Loading the startup Scheme files. */
+
+/* The boot code "ice-9/boot-9" is only loaded by scm_boot_guile when
+ this is false. The unexec code uses this, to keep ice_9 from being
+ loaded into dumped guile executables. */
+int scm_ice_9_already_loaded = 0;
+
+void
+scm_load_startup_files ()
+{
+ /* 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"));
+
+ /* Load Ice-9. */
+ if (!scm_ice_9_already_loaded)
+ {
+ scm_primitive_load_path (scm_makfrom0str ("ice-9/boot-9.scm"));
+
+ /* Load the init.scm file. */
+ if (SCM_NFALSEP (init_path))
+ scm_primitive_load (init_path);
+
+ scm_post_boot_init_modules ();
+ }
+}
+
+\f
+/* The main init code. */
+
+#ifdef _UNICOS
+typedef int setjmp_type;
+#else
+typedef long setjmp_type;
+#endif
+
+/* All the data needed to invoke the main function. */
+struct main_func_closure
+{
+ /* the function to call */
+ void (*main_func)(void *closure, int argc, char **argv);
+ void *closure; /* dummy data to pass it */
+ int argc;
+ char **argv; /* the argument list it should receive */
+};
+
+
+static void scm_init_guile_1 (SCM_STACKITEM *base);
+static void scm_boot_guile_1 (SCM_STACKITEM *base,
+ struct main_func_closure *closure);
+static SCM invoke_main_func(void *body_data);
+
+
+/* Fire up the Guile Scheme interpreter.
+
+ Call MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV. MAIN_FUNC
+ should do all the work of the program (initializing other packages,
+ reading user input, etc.) before returning. When MAIN_FUNC
+ returns, call exit (0); this function never returns. If you want
+ some other exit value, MAIN_FUNC may call exit itself.
+
+ scm_boot_guile arranges for program-arguments to return the strings
+ given by ARGC and ARGV. If MAIN_FUNC modifies ARGC/ARGV, should
+ call scm_set_program_arguments with the final list, so Scheme code
+ will know which arguments have been processed.
+
+ scm_boot_guile establishes a catch-all catch handler which prints
+ an error message and exits the process. This means that Guile
+ exits in a coherent way when system errors occur and the user isn't
+ prepared to handle it. If the user doesn't like this behavior,
+ they can establish their own universal catcher to shadow this one.
+
+ Why must the caller do all the real work from MAIN_FUNC? The
+ garbage collector assumes that all local variables of type SCM will
+ be above scm_boot_guile's stack frame on the stack. If you try to
+ manipulate SCM values after this function returns, it's the luck of
+ the draw whether the GC will be able to find the objects you
+ allocate. So, scm_boot_guile function exits, rather than
+ returning, to discourage people from making that mistake. */
+
+
+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.closure = closure;
+ c.argc = argc;
+ c.argv = argv;
+
+ scm_boot_guile_1 (&dummy, &c);
+}
+
+void
+scm_init_guile ()
+{
+ scm_init_guile_1 ((SCM_STACKITEM *)scm_get_stack_base ());
+}
+
+int scm_initialized_p = 0;
+
+static void
+scm_init_guile_1 (SCM_STACKITEM *base)
+{
+ if (scm_initialized_p)
+ return;
+
+ if (base == NULL)
+ {
+ fprintf (stderr, "cannot determine stack base!\n");
+ abort ();
+ }
+
+ scm_ints_disabled = 1;
+ scm_block_gc = 1;
+
+ scm_ports_prehistory ();
+ scm_smob_prehistory ();
+ scm_tables_prehistory ();
+#ifdef GUILE_DEBUG_MALLOC
+ scm_debug_malloc_prehistory ();
+#endif
+ scm_init_storage ();
+ scm_struct_prehistory (); /* requires storage */
+ scm_symbols_prehistory (); /* requires storage */
+ scm_weaks_prehistory (); /* requires storage */
+ scm_init_subr_table ();
+ scm_environments_prehistory (); /* create the root environment */
+ scm_init_continuations ();
+ scm_init_root (); /* requires continuations */
+#ifdef USE_THREADS
+ scm_init_threads (base);
+#endif
+ start_stack (base);
+ scm_init_gsubr ();
+ scm_init_procprop ();
+ scm_init_environments ();
+ scm_init_feature ();
+ 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_gdbint ();
+ scm_init_hash ();
+ scm_init_hashtab ();
+ scm_init_objprop ();
+ scm_init_properties ();
+ scm_init_hooks (); /* Requires objprop until hook names are removed */
+ scm_init_gc (); /* Requires hooks, async */
+#ifdef GUILE_ISELECT
+ scm_init_iselect ();
+#endif
+ 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 ();
+#endif
+#ifdef HAVE_REGCOMP
+ scm_init_regex_posix ();
+#endif
+ scm_init_procs ();
+ scm_init_scmsigs ();
+#ifdef HAVE_NETWORKING
+ scm_init_net_db ();
+ scm_init_socket ();
+#endif
+ scm_init_sort ();
+#ifdef DEBUG_EXTENSIONS
+ scm_init_srcprop ();
+#endif
+ scm_init_stackchk ();
+ scm_init_struct ();
+ scm_init_stacks (); /* Requires struct */
+ scm_init_strports ();
+ scm_init_symbols ();
+ scm_init_tag ();
+ scm_init_values (); /* Requires struct */
+ 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 ();
+#endif
+ scm_init_simpos ();
+ scm_init_load_path ();
+ scm_init_standard_ports ();
+ scm_init_dynamic_linking ();
+ scm_init_lang ();
+ scm_init_script ();
+
+ scm_init_oop_goops_goopscore_module ();
+
+ scm_initialized_p = 1;
+
+ scm_block_gc = 0; /* permit the gc to run */
+ /* ints still disabled */
+
+#ifdef STACK_CHECKING
+ scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
+#endif
+
+ scm_load_startup_files ();
+}
+
+/* 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...) */
+
+int scm_boot_guile_1_live = 0;
+
+static void
+scm_boot_guile_1 (SCM_STACKITEM *base, struct main_func_closure *closure)
+{
+ scm_init_guile_1 (base);
+
+ /* This function is not re-entrant. */
+ if (scm_boot_guile_1_live)
+ abort ();
+
+ scm_boot_guile_1_live = 1;
+
+ scm_set_program_arguments (closure->argc, closure->argv, 0);
+ invoke_main_func (closure);
+
+ 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;
+
+ (*closure->main_func) (closure->closure, closure->argc, closure->argv);
+
+ /* never reached */
+ return SCM_UNDEFINED;
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff