[bpt/guile.git] / libguile / init.c

/*	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;
}
Commit	Line	Data
0f2d19dd JB	1	/* Copyright (C) 1995,1996 Free Software Foundation, Inc.
	2	*
	3	* This program is free software; you can redistribute it and/or modify
	4	* it under the terms of the GNU General Public License as published by
	5	* the Free Software Foundation; either version 2, or (at your option)
	6	* any later version.
	7	*
	8	* This program is distributed in the hope that it will be useful,
	9	* but WITHOUT ANY WARRANTY; without even the implied warranty of
	10	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	11	* GNU General Public License for more details.
	12	*
	13	* You should have received a copy of the GNU General Public License
	14	* along with this software; see the file COPYING. If not, write to
	15	* the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
	16	*
	17	* As a special exception, the Free Software Foundation gives permission
	18	* for additional uses of the text contained in its release of GUILE.
	19	*
	20	* The exception is that, if you link the GUILE library with other files
	21	* to produce an executable, this does not by itself cause the
	22	* resulting executable to be covered by the GNU General Public License.
	23	* Your use of that executable is in no way restricted on account of
	24	* linking the GUILE library code into it.
	25	*
	26	* This exception does not however invalidate any other reasons why
	27	* the executable file might be covered by the GNU General Public License.
	28	*
	29	* This exception applies only to the code released by the
	30	* Free Software Foundation under the name GUILE. If you copy
	31	* code from other Free Software Foundation releases into a copy of
	32	* GUILE, as the General Public License permits, the exception does
	33	* not apply to the code that you add in this way. To avoid misleading
	34	* anyone as to the status of such modified files, you must delete
	35	* this exception notice from them.
	36	*
	37	* If you write modifications of your own for GUILE, it is your choice
	38	* whether to permit this exception to apply to your modifications.
	39	* If you do not wish that, delete this exception notice.
	40	*/
	41	\f
	42
	43	#include <stdio.h>
	44	#include "_scm.h"
	45
20e6290e JB	46	/* Everybody has an init function. */
	47	#include "alist.h"
	48	#include "append.h"
	49	#include "arbiters.h"
	50	#include "async.h"
0e44fcca	51	#include "backtrace.h"
20e6290e JB	52	#include "boolean.h"
	53	#include "chars.h"
	54	#include "continuations.h"
	55	#ifdef DEBUG_EXTENSIONS
	56	#include "debug.h"
	57	#endif
	58	#include "dynwind.h"
	59	#include "eq.h"
	60	#include "error.h"
	61	#include "eval.h"
	62	#include "fdsocket.h"
	63	#include "feature.h"
20e6290e JB	64	#include "filesys.h"
	65	#include "fports.h"
	66	#include "gc.h"
	67	#include "gdbint.h"
	68	#include "gsubr.h"
	69	#include "hash.h"
	70	#include "hashtab.h"
	71	#include "ioext.h"
	72	#include "kw.h"
	73	#include "list.h"
	74	#include "load.h"
	75	#include "mallocs.h"
	76	#include "mbstrings.h"
	77	#include "numbers.h"
	78	#include "objprop.h"
	79	#include "options.h"
	80	#include "pairs.h"
	81	#include "ports.h"
	82	#include "posix.h"
	83	#include "print.h"
	84	#include "procprop.h"
	85	#include "procs.h"
	86	#include "ramap.h"
	87	#include "read.h"
	88	#include "scmsigs.h"
	89	#include "sequences.h"
	90	#include "simpos.h"
a8be22fe	91	#include "smob.h"
20e6290e JB	92	#include "socket.h"
	93	#include "srcprop.h"
	94	#include "stackchk.h"
0e44fcca	95	#include "stacks.h"
20e6290e JB	96	#include "stime.h"
	97	#include "strings.h"
	98	#include "strop.h"
	99	#include "strorder.h"
	100	#include "strports.h"
	101	#include "struct.h"
	102	#include "symbols.h"
	103	#include "tag.h"
	104	#include "throw.h"
	105	#include "unif.h"
	106	#include "variable.h"
	107	#include "vectors.h"
	108	#include "version.h"
	109	#include "vports.h"
	110	#include "weaks.h"
	111
a8be22fe JB	112	#include "init.h"
a8be22fe JB	113
95b88819 GH	114	#ifdef HAVE_STRING_H
	115	#include <string.h>
	116	#endif
	117	#ifdef HAVE_UNISTD_H
	118	#include <unistd.h>
	119	#endif
0f2d19dd JB	120	\f
0f2d19dd JB	121
0f2d19dd JB	122	void
	123	scm_start_stack (base, in, out, err)
	124	void * base;
	125	FILE * in;
	126	FILE * out;
	127	FILE * err;
0f2d19dd	128	{
9ef3d0ee	129	SCM root;
0f2d19dd JB	130	struct scm_port_table * pt;
0f2d19dd JB	131
9ef3d0ee MD	132	root = scm_permanent_object (scm_make_root (SCM_UNDEFINED));
	133	scm_set_root (SCM_ROOT_STATE (root));
	134
0f2d19dd JB	135	scm_stack_base = base;
0f2d19dd JB	136
4e1caa79	137	/* Create standard ports from stdio files, if requested to do so.
0f2d19dd JB	138	*/
	139
	140	if (!in)
	141	{
	142	scm_def_inp = SCM_BOOL_F;
	143	}
	144	else
	145	{
	146	SCM_NEWCELL (scm_def_inp);
	147	pt = scm_add_to_port_table (scm_def_inp);
898a256f	148	SCM_SETCAR (scm_def_inp, (scm_tc16_fport \| SCM_OPN \| SCM_RDNG));
0f2d19dd JB	149	SCM_SETPTAB_ENTRY (scm_def_inp, pt);
	150	SCM_SETSTREAM (scm_def_inp, (SCM)in);
	151	if (isatty (fileno (in)))
	152	{
	153	scm_setbuf0 (scm_def_inp); /* turn off stdin buffering */
898a256f	154	SCM_SETOR_CAR (scm_def_inp, SCM_BUF0);
0f2d19dd JB	155	}
	156	scm_set_port_revealed_x (scm_def_inp, SCM_MAKINUM (1));
	157	}
	158
	159	if (!out)
	160	{
	161	scm_def_outp = SCM_BOOL_F;
	162	}
	163	else
	164	{
	165	SCM_NEWCELL (scm_def_outp);
	166	pt = scm_add_to_port_table (scm_def_outp);
898a256f	167	SCM_SETCAR (scm_def_outp, (scm_tc16_fport \| SCM_OPN \| SCM_WRTNG));
0f2d19dd JB	168	SCM_SETPTAB_ENTRY (scm_def_outp, pt);
	169	SCM_SETSTREAM (scm_def_outp, (SCM)out);
	170	scm_set_port_revealed_x (scm_def_outp, SCM_MAKINUM (1));
	171	}
	172
	173	if (!err)
	174	{
	175	scm_def_errp = SCM_BOOL_F;
	176	}
	177	else
	178	{
	179	SCM_NEWCELL (scm_def_errp);
	180	pt = scm_add_to_port_table (scm_def_errp);
898a256f	181	SCM_SETCAR (scm_def_errp, (scm_tc16_fport \| SCM_OPN \| SCM_WRTNG));
0f2d19dd JB	182	SCM_SETPTAB_ENTRY (scm_def_errp, pt);
	183	SCM_SETSTREAM (scm_def_errp, (SCM)err);
	184	scm_set_port_revealed_x (scm_def_errp, SCM_MAKINUM (1));
	185	}
	186
	187	scm_cur_inp = scm_def_inp;
	188	scm_cur_outp = scm_def_outp;
	189	scm_cur_errp = scm_def_errp;
	190
	191
	192	scm_progargs = SCM_BOOL_F; /* vestigial */
	193	scm_exitval = SCM_BOOL_F; /* vestigial */
	194
	195	scm_top_level_lookup_thunk_var = SCM_BOOL_F;
	196	scm_system_transformer = SCM_BOOL_F;
	197
	198	/* Create an object to hold the root continuation.
	199	*/
	200	SCM_NEWCELL (scm_rootcont);
0e44fcca	201	SCM_SETJMPBUF (scm_rootcont, scm_must_malloc ((long) sizeof (scm_contregs), "continuation"));
898a256f	202	SCM_SETCAR (scm_rootcont, scm_tc7_contin);
4b5166ac	203	SCM_SEQ (scm_rootcont) = 0;
0f2d19dd JB	204	/* The root continuation if further initialized by scm_restart_stack. */
	205
	206	/* Create the look-aside stack for variables that are shared between
	207	* captured continuations.
	208	*/
	209	scm_continuation_stack = scm_make_vector (SCM_MAKINUM (512), SCM_UNDEFINED, SCM_UNDEFINED);
	210	/* The continuation stack is further initialized by scm_restart_stack. */
	211
	212	/* The remainder of stack initialization is factored out to another function so that
	213	* if this stack is ever exitted, it can be re-entered using scm_restart_stack.
	214	*/
	215	scm_restart_stack (base);
	216	}
	217
	218
0f2d19dd JB	219	void
	220	scm_restart_stack (base)
	221	void * base;
0f2d19dd JB	222	{
	223	scm_dynwinds = SCM_EOL;
	224	SCM_DYNENV (scm_rootcont) = SCM_EOL;
	225	SCM_THROW_VALUE (scm_rootcont) = SCM_EOL;
4e1caa79	226	#ifdef DEBUG_EXTENSIONS
4b5166ac	227	SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
4e1caa79	228	#endif
0f2d19dd JB	229	SCM_BASE (scm_rootcont) = base;
	230	scm_continuation_stack_ptr = SCM_MAKINUM (0);
	231	}
	232
	233	#if 0
	234	static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
	235
1cc91f1b JB	236
	237	static void fixconfig SCM_P ((char s1, char s2, int s));
	238
0f2d19dd JB	239	static void
	240	fixconfig (s1, s2, s)
	241	char *s1;
	242	char *s2;
	243	int s;
0f2d19dd JB	244	{
	245	fputs (s1, stderr);
	246	fputs (s2, stderr);
	247	fputs ("\nin ", stderr);
	248	fputs (s ? "setjump" : "scmfig", stderr);
	249	fputs (".h and recompile scm\n", stderr);
	250	exit (1);
	251	}
	252
	253
1cc91f1b	254	static void check_config SCM_P ((void));
0f2d19dd JB	255
	256	static void
	257	check_config ()
	258	{
	259	scm_sizet j;
	260
	261	j = HEAP_SEG_SIZE;
	262	if (HEAP_SEG_SIZE != j)
	263	fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);
	264
	265	#ifdef SCM_SINGLES
	266	if (sizeof (float) != sizeof (long))
	267	fixconfig (remsg, "SCM_SINGLES", 0);
	268	#endif /* def SCM_SINGLES */
	269
	270
	271	#ifdef SCM_BIGDIG
	272	if (2 * SCM_BITSPERDIG / SCM_CHAR_BIT > sizeof (long))
	273	fixconfig (remsg, "SCM_BIGDIG", 0);
	274	#ifndef SCM_DIGSTOOBIG
	275	if (SCM_DIGSPERLONG * sizeof (SCM_BIGDIG) > sizeof (long))
	276	fixconfig (addmsg, "SCM_DIGSTOOBIG", 0);
	277	#endif
	278	#endif
	279
	280	#ifdef SCM_STACK_GROWS_UP
	281	if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0)
	282	fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
	283	#else
	284	if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0)
	285	fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1);
	286	#endif
	287	}
	288	#endif
	289
	290
	291	\f
	292	#ifdef _UNICOS
	293	typedef int setjmp_type;
	294	#else
	295	typedef long setjmp_type;
	296	#endif
	297
	298	/* Fire up Scheme.
	299	*
	300	* argc and argv are made the return values of program-arguments.
	301	*
	302	* in, out, and err, if not NULL, become the standard ports.
47b44240	303	* If NULL is passed, your "initfunc" should set up the
0f2d19dd JB	304	* standard ports.
	305	*
	306	* boot_cmd is a string containing a Scheme expression to evaluate
	307	* to get things rolling.
	308	*
	309	* result is returned a string containing a printed result of evaluating
	310	* the boot command.
	311	*
	312	* the return value is:
	313	* scm_boot_ok - evaluation concluded normally
	314	* scm_boot_error - evaluation concluded with a Scheme error
	315	* scm_boot_emem - allocation error mallocing *result
47b44240 JB	316	* scm_boot_ereenter - scm_boot_guile was called re-entrantly, which is
47b44240 JB	317	* prohibited.
0f2d19dd JB	318	*/
0f2d19dd JB	319
4b89050f	320	int scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base,
c275ddc7 JB	321	char **result,
	322	int argc, char **argv,
	323	FILE in, FILE out, FILE *err,
	324	void (*init_func) (),
	325	char *boot_cmd));
	326
0f2d19dd	327	int
47b44240	328	scm_boot_guile (result, argc, argv, in, out, err, init_func, boot_cmd)
0f2d19dd JB	329	char ** result;
	330	int argc;
	331	char ** argv;
	332	FILE * in;
	333	FILE * out;
	334	FILE * err;
47b44240	335	void (*init_func) ();
0f2d19dd	336	char * boot_cmd;
c275ddc7 JB	337	{
	338	SCM_STACKITEM dummy;
	339
	340	return scm_boot_guile_1 (&dummy, result, argc, argv, in, out, err,
	341	init_func, boot_cmd);
	342	}
	343
4b89050f	344	int
c275ddc7 JB	345	scm_boot_guile_1 (base, result, argc, argv, in, out, err, init_func, boot_cmd)
	346	SCM_STACKITEM *base;
	347	char ** result;
	348	int argc;
	349	char ** argv;
	350	FILE * in;
	351	FILE * out;
	352	FILE * err;
	353	void (*init_func) ();
	354	char * boot_cmd;
0f2d19dd JB	355	{
	356	static int initialized = 0;
	357	static int live = 0;
0f2d19dd JB	358	setjmp_type setjmp_val;
	359	int stat;
	360
	361	if (live) /* This function is not re-entrant. */
	362	{
	363	return scm_boot_ereenter;
	364	}
	365
	366	live = 1;
	367
	368	scm_ints_disabled = 1;
	369	scm_block_gc = 1;
	370
	371	if (initialized)
	372	{
c275ddc7	373	scm_restart_stack (base);
0f2d19dd JB	374	}
	375	else
	376	{
	377	scm_ports_prehistory ();
	378	scm_smob_prehistory ();
	379	scm_tables_prehistory ();
	380	scm_init_storage (0);
9ef3d0ee MD	381	scm_init_root ();
9ef3d0ee MD	382	#ifdef USE_THREADS
a239e35b	383	scm_init_threads (base);
9ef3d0ee	384	#endif
c275ddc7	385	scm_start_stack (base, in, out, err);
0f2d19dd JB	386	scm_init_gsubr ();
	387	scm_init_feature ();
	388	scm_init_alist ();
	389	scm_init_append ();
	390	scm_init_arbiters ();
	391	scm_init_async ();
0e44fcca	392	scm_init_backtrace ();
0f2d19dd JB	393	scm_init_boolean ();
	394	scm_init_chars ();
	395	scm_init_continuations ();
	396	scm_init_dynwind ();
	397	scm_init_eq ();
	398	scm_init_error ();
	399	scm_init_fdsocket ();
	400	scm_init_fports ();
0f2d19dd JB	401	scm_init_filesys ();
0f2d19dd JB	402	scm_init_gc ();
68cd9c71	403	scm_init_gdbint ();
0f2d19dd JB	404	scm_init_hash ();
	405	scm_init_hashtab ();
	406	scm_init_ioext ();
	407	scm_init_kw ();
	408	scm_init_list ();
	409	scm_init_mallocs ();
	410	scm_init_numbers ();
	411	scm_init_objprop ();
4e1caa79 MD	412	#if DEBUG_EXTENSIONS
	413	/* Excluding this until it's really needed makes the binary
	414	* smaller after linking. */
	415	scm_init_options ();
	416	#endif
0f2d19dd JB	417	scm_init_pairs ();
	418	scm_init_ports ();
	419	scm_init_posix ();
	420	scm_init_procs ();
	421	scm_init_procprop ();
0f2d19dd JB	422	scm_init_scmsigs ();
0f2d19dd JB	423	scm_init_socket ();
4e1caa79 MD	424	#ifdef DEBUG_EXTENSIONS
	425	scm_init_srcprop ();
	426	#endif
0f2d19dd	427	scm_init_stackchk ();
7439c0b9	428	scm_init_struct (); /* Requires struct */
0e44fcca	429	scm_init_stacks ();
0f2d19dd	430	scm_init_strports ();
0f2d19dd JB	431	scm_init_symbols ();
	432	scm_init_tag ();
	433	scm_init_load ();
90b826c9	434	scm_init_print (); /* Requires struct */
0f2d19dd JB	435	scm_init_read ();
	436	scm_init_sequences ();
	437	scm_init_stime ();
	438	scm_init_strings ();
	439	scm_init_strorder ();
	440	scm_init_mbstrings ();
	441	scm_init_strop ();
	442	scm_init_throw ();
	443	scm_init_variable ();
	444	scm_init_vectors ();
9d7e1edf	445	scm_init_version ();
0f2d19dd JB	446	scm_init_weaks ();
	447	scm_init_vports ();
	448	scm_init_eval ();
0e44fcca MD	449	#ifdef DEBUG_EXTENSIONS
	450	scm_init_debug (); /* Requires macro smobs */
	451	#endif
0f2d19dd JB	452	scm_init_ramap ();
	453	scm_init_unif ();
	454	scm_init_simpos ();
0f2d19dd	455	scm_progargs = scm_makfromstrs (argc, argv);
24f93c27	456	scm_init_load_path ();
0f2d19dd JB	457	initialized = 1;
	458	}
	459
	460	scm_block_gc = 0; /* permit the gc to run */
	461	/* ints still disabled */
	462
	463	{
	464	SCM command;
	465
	466	command = scm_makfrom0str (boot_cmd);
	467
	468	setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont));
	469
faa6b3df MD	470	#ifdef STACK_CHECKING
	471	scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
	472	#endif
0f2d19dd JB	473	if (!setjmp_val)
0f2d19dd JB	474	{
3d40d7b6	475	SCM last = SCM_UNDEFINED;
0f2d19dd JB	476	scm_init_signals ();
0f2d19dd JB	477
47b44240 JB	478	/* Call the initialization function passed in by the user, if
	479	present. */
	480	if (init_func) (*init_func) ();
	481
	482	/* Evaluate boot_cmd string. */
0f2d19dd JB	483	{
	484	SCM p;
	485	SCM form;
	486
	487	p = scm_mkstrport (SCM_MAKINUM (0),
	488	command,
	489	SCM_OPN \| SCM_RDNG,
	490	"boot_guile");
	491	while (1)
	492	{
	493	form = scm_read (p, SCM_BOOL_F, SCM_BOOL_F);
	494	if (SCM_EOF_VAL == form)
	495	break;
	496	last = scm_eval_x (form);
	497	}
	498
	499	}
	500
	501	scm_restore_signals ();
	502	/* This tick gives any pending
	503	* asyncs a chance to run. This must be done after
	504	* the call to scm_restore_signals.
	505	*/
	506	SCM_ASYNC_TICK;
	507
	508	scm_ints_disabled = 1; /* Hopefully redundant but just to be sure. */
	509
	510	{
	511	SCM str_answer;
	512
	513	str_answer = scm_strprint_obj (last);
	514	result = (char )malloc (1 + SCM_LENGTH (str_answer));
	515	if (!*result)
	516	stat = scm_boot_emem;
	517	else
	518	{
	519	memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer));
	520	(*result)[SCM_LENGTH (str_answer)] = 0;
	521	stat = scm_boot_ok;
	522	}
	523	}
	524	}
	525	else
	526	{
	527	/* This is reached if an unhandled throw terminated Scheme.
	528	* Such an occurence should be extremely unlikely -- it indicates
	529	* a programming error in the boot code.
	530	*
	531	* Details of the bogus exception are stored in scm_exitval even
	532	* though that isn't currently reflected in the return value.
	533	* !!!
	534	*/
	535
	536	scm_restore_signals ();
	537	/* This tick gives any pending
	538	* asyncs a chance to run. This must be done after
	539	* the call to scm_restore_signals.
	540	*
	541	* Note that an unhandled exception during signal handling
	542	* will put as back at the call to scm_restore_signals immediately
	543	* preceeding. A sufficiently bogus signal handler could
	544	* conceivably cause an infinite loop here.
	545	*/
	546	SCM_ASYNC_TICK;
547
548	scm_ints_disabled = 1; /* Hopefully redundant but just to be sure. */
549
550	{
551	SCM str_answer;
552
553	str_answer = scm_strprint_obj (scm_exitval);
554	result = (char )malloc (1 + SCM_LENGTH (str_answer));
555	if (!*result)
556	stat = scm_boot_emem;
557	else
558	{
559	memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer));
560	(*result)[SCM_LENGTH (str_answer)] = 0;
561	stat = scm_boot_error;
562	}
563	}
564	}
565	}
566
567	scm_block_gc = 1;
568	live = 0;
569	return stat;
570	}