[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 "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 "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_CAR (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_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_CAR (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_CAR (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 (regs), "continuation"));
  SCM_CAR (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.
 */

static 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);
}

static 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_boolean ();
      scm_init_chars ();
      scm_init_continuations ();
#ifdef DEBUG_EXTENSIONS
      scm_init_debug ();
#endif
      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_strports ();
      scm_init_symbols ();
      scm_init_tag ();
      scm_init_load ();
      scm_init_struct ();
      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 ();
      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"
	51	#include "boolean.h"
	52	#include "chars.h"
	53	#include "continuations.h"
	54	#ifdef DEBUG_EXTENSIONS
	55	#include "debug.h"
	56	#endif
	57	#include "dynwind.h"
	58	#include "eq.h"
	59	#include "error.h"
	60	#include "eval.h"
	61	#include "fdsocket.h"
	62	#include "feature.h"
20e6290e JB	63	#include "filesys.h"
	64	#include "fports.h"
	65	#include "gc.h"
	66	#include "gdbint.h"
	67	#include "gsubr.h"
	68	#include "hash.h"
	69	#include "hashtab.h"
	70	#include "ioext.h"
	71	#include "kw.h"
	72	#include "list.h"
	73	#include "load.h"
	74	#include "mallocs.h"
	75	#include "mbstrings.h"
	76	#include "numbers.h"
	77	#include "objprop.h"
	78	#include "options.h"
	79	#include "pairs.h"
	80	#include "ports.h"
	81	#include "posix.h"
	82	#include "print.h"
	83	#include "procprop.h"
	84	#include "procs.h"
	85	#include "ramap.h"
	86	#include "read.h"
	87	#include "scmsigs.h"
	88	#include "sequences.h"
	89	#include "simpos.h"
a8be22fe	90	#include "smob.h"
20e6290e JB	91	#include "socket.h"
	92	#include "srcprop.h"
	93	#include "stackchk.h"
	94	#include "stime.h"
	95	#include "strings.h"
	96	#include "strop.h"
	97	#include "strorder.h"
	98	#include "strports.h"
	99	#include "struct.h"
	100	#include "symbols.h"
	101	#include "tag.h"
	102	#include "throw.h"
	103	#include "unif.h"
	104	#include "variable.h"
	105	#include "vectors.h"
	106	#include "version.h"
	107	#include "vports.h"
	108	#include "weaks.h"
	109
a8be22fe JB	110	#include "init.h"
a8be22fe JB	111
95b88819 GH	112	#ifdef HAVE_STRING_H
	113	#include <string.h>
	114	#endif
	115	#ifdef HAVE_UNISTD_H
	116	#include <unistd.h>
	117	#endif
0f2d19dd JB	118	\f
0f2d19dd JB	119
0f2d19dd JB	120	void
	121	scm_start_stack (base, in, out, err)
	122	void * base;
	123	FILE * in;
	124	FILE * out;
	125	FILE * err;
0f2d19dd	126	{
9ef3d0ee	127	SCM root;
0f2d19dd JB	128	struct scm_port_table * pt;
0f2d19dd JB	129
9ef3d0ee MD	130	root = scm_permanent_object (scm_make_root (SCM_UNDEFINED));
	131	scm_set_root (SCM_ROOT_STATE (root));
	132
0f2d19dd JB	133	scm_stack_base = base;
0f2d19dd JB	134
4e1caa79	135	/* Create standard ports from stdio files, if requested to do so.
0f2d19dd JB	136	*/
	137
	138	if (!in)
	139	{
	140	scm_def_inp = SCM_BOOL_F;
	141	}
	142	else
	143	{
	144	SCM_NEWCELL (scm_def_inp);
	145	pt = scm_add_to_port_table (scm_def_inp);
	146	SCM_CAR (scm_def_inp) = (scm_tc16_fport \| SCM_OPN \| SCM_RDNG);
	147	SCM_SETPTAB_ENTRY (scm_def_inp, pt);
	148	SCM_SETSTREAM (scm_def_inp, (SCM)in);
	149	if (isatty (fileno (in)))
	150	{
	151	scm_setbuf0 (scm_def_inp); /* turn off stdin buffering */
	152	SCM_CAR (scm_def_inp) \|= SCM_BUF0;
	153	}
	154	scm_set_port_revealed_x (scm_def_inp, SCM_MAKINUM (1));
	155	}
	156
	157	if (!out)
	158	{
	159	scm_def_outp = SCM_BOOL_F;
	160	}
	161	else
	162	{
	163	SCM_NEWCELL (scm_def_outp);
	164	pt = scm_add_to_port_table (scm_def_outp);
	165	SCM_CAR (scm_def_outp) = (scm_tc16_fport \| SCM_OPN \| SCM_WRTNG);
	166	SCM_SETPTAB_ENTRY (scm_def_outp, pt);
	167	SCM_SETSTREAM (scm_def_outp, (SCM)out);
	168	scm_set_port_revealed_x (scm_def_outp, SCM_MAKINUM (1));
	169	}
	170
	171	if (!err)
	172	{
	173	scm_def_errp = SCM_BOOL_F;
	174	}
	175	else
	176	{
	177	SCM_NEWCELL (scm_def_errp);
	178	pt = scm_add_to_port_table (scm_def_errp);
	179	SCM_CAR (scm_def_errp) = (scm_tc16_fport \| SCM_OPN \| SCM_WRTNG);
	180	SCM_SETPTAB_ENTRY (scm_def_errp, pt);
	181	SCM_SETSTREAM (scm_def_errp, (SCM)err);
	182	scm_set_port_revealed_x (scm_def_errp, SCM_MAKINUM (1));
	183	}
	184
	185	scm_cur_inp = scm_def_inp;
	186	scm_cur_outp = scm_def_outp;
	187	scm_cur_errp = scm_def_errp;
	188
	189
	190	scm_progargs = SCM_BOOL_F; /* vestigial */
	191	scm_exitval = SCM_BOOL_F; /* vestigial */
	192
	193	scm_top_level_lookup_thunk_var = SCM_BOOL_F;
	194	scm_system_transformer = SCM_BOOL_F;
	195
	196	/* Create an object to hold the root continuation.
	197	*/
	198	SCM_NEWCELL (scm_rootcont);
	199	SCM_SETJMPBUF (scm_rootcont, scm_must_malloc ((long) sizeof (regs), "continuation"));
200	SCM_CAR (scm_rootcont) = scm_tc7_contin;
4b5166ac	201	SCM_SEQ (scm_rootcont) = 0;
0f2d19dd JB	202	/* The root continuation if further initialized by scm_restart_stack. */
	203
	204	/* Create the look-aside stack for variables that are shared between
	205	* captured continuations.
	206	*/
	207	scm_continuation_stack = scm_make_vector (SCM_MAKINUM (512), SCM_UNDEFINED, SCM_UNDEFINED);
	208	/* The continuation stack is further initialized by scm_restart_stack. */
	209
	210	/* The remainder of stack initialization is factored out to another function so that
	211	* if this stack is ever exitted, it can be re-entered using scm_restart_stack.
	212	*/
	213	scm_restart_stack (base);
	214	}
	215
	216
0f2d19dd JB	217	void
	218	scm_restart_stack (base)
	219	void * base;
0f2d19dd JB	220	{
	221	scm_dynwinds = SCM_EOL;
	222	SCM_DYNENV (scm_rootcont) = SCM_EOL;
	223	SCM_THROW_VALUE (scm_rootcont) = SCM_EOL;
4e1caa79	224	#ifdef DEBUG_EXTENSIONS
4b5166ac	225	SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
4e1caa79	226	#endif
0f2d19dd JB	227	SCM_BASE (scm_rootcont) = base;
	228	scm_continuation_stack_ptr = SCM_MAKINUM (0);
	229	}
	230
	231	#if 0
	232	static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
	233
1cc91f1b JB	234
	235	static void fixconfig SCM_P ((char s1, char s2, int s));
	236
0f2d19dd JB	237	static void
	238	fixconfig (s1, s2, s)
	239	char *s1;
	240	char *s2;
	241	int s;
0f2d19dd JB	242	{
	243	fputs (s1, stderr);
	244	fputs (s2, stderr);
	245	fputs ("\nin ", stderr);
	246	fputs (s ? "setjump" : "scmfig", stderr);
	247	fputs (".h and recompile scm\n", stderr);
	248	exit (1);
	249	}
	250
	251
1cc91f1b	252	static void check_config SCM_P ((void));
0f2d19dd JB	253
	254	static void
	255	check_config ()
	256	{
	257	scm_sizet j;
	258
	259	j = HEAP_SEG_SIZE;
	260	if (HEAP_SEG_SIZE != j)
	261	fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);
	262
	263	#ifdef SCM_SINGLES
	264	if (sizeof (float) != sizeof (long))
	265	fixconfig (remsg, "SCM_SINGLES", 0);
	266	#endif /* def SCM_SINGLES */
	267
	268
	269	#ifdef SCM_BIGDIG
	270	if (2 * SCM_BITSPERDIG / SCM_CHAR_BIT > sizeof (long))
	271	fixconfig (remsg, "SCM_BIGDIG", 0);
	272	#ifndef SCM_DIGSTOOBIG
	273	if (SCM_DIGSPERLONG * sizeof (SCM_BIGDIG) > sizeof (long))
	274	fixconfig (addmsg, "SCM_DIGSTOOBIG", 0);
	275	#endif
	276	#endif
	277
	278	#ifdef SCM_STACK_GROWS_UP
	279	if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0)
	280	fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
	281	#else
	282	if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0)
	283	fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1);
	284	#endif
	285	}
	286	#endif
	287
	288
	289	\f
	290	#ifdef _UNICOS
	291	typedef int setjmp_type;
	292	#else
	293	typedef long setjmp_type;
	294	#endif
	295
	296	/* Fire up Scheme.
	297	*
	298	* argc and argv are made the return values of program-arguments.
	299	*
	300	* in, out, and err, if not NULL, become the standard ports.
47b44240	301	* If NULL is passed, your "initfunc" should set up the
0f2d19dd JB	302	* standard ports.
	303	*
	304	* boot_cmd is a string containing a Scheme expression to evaluate
	305	* to get things rolling.
	306	*
	307	* result is returned a string containing a printed result of evaluating
	308	* the boot command.
	309	*
	310	* the return value is:
	311	* scm_boot_ok - evaluation concluded normally
	312	* scm_boot_error - evaluation concluded with a Scheme error
	313	* scm_boot_emem - allocation error mallocing *result
47b44240 JB	314	* scm_boot_ereenter - scm_boot_guile was called re-entrantly, which is
47b44240 JB	315	* prohibited.
0f2d19dd JB	316	*/
0f2d19dd JB	317
c275ddc7 JB	318	static int scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base,
	319	char **result,
	320	int argc, char **argv,
	321	FILE in, FILE out, FILE *err,
	322	void (*init_func) (),
	323	char *boot_cmd));
	324
0f2d19dd	325	int
47b44240	326	scm_boot_guile (result, argc, argv, in, out, err, init_func, boot_cmd)
0f2d19dd JB	327	char ** result;
	328	int argc;
	329	char ** argv;
	330	FILE * in;
	331	FILE * out;
	332	FILE * err;
47b44240	333	void (*init_func) ();
0f2d19dd	334	char * boot_cmd;
c275ddc7 JB	335	{
	336	SCM_STACKITEM dummy;
	337
	338	return scm_boot_guile_1 (&dummy, result, argc, argv, in, out, err,
	339	init_func, boot_cmd);
	340	}
	341
	342	static int
	343	scm_boot_guile_1 (base, result, argc, argv, in, out, err, init_func, boot_cmd)
	344	SCM_STACKITEM *base;
	345	char ** result;
	346	int argc;
	347	char ** argv;
	348	FILE * in;
	349	FILE * out;
	350	FILE * err;
	351	void (*init_func) ();
	352	char * boot_cmd;
0f2d19dd JB	353	{
	354	static int initialized = 0;
	355	static int live = 0;
0f2d19dd JB	356	setjmp_type setjmp_val;
	357	int stat;
	358
	359	if (live) /* This function is not re-entrant. */
	360	{
	361	return scm_boot_ereenter;
	362	}
	363
	364	live = 1;
	365
	366	scm_ints_disabled = 1;
	367	scm_block_gc = 1;
	368
	369	if (initialized)
	370	{
c275ddc7	371	scm_restart_stack (base);
0f2d19dd JB	372	}
	373	else
	374	{
	375	scm_ports_prehistory ();
	376	scm_smob_prehistory ();
	377	scm_tables_prehistory ();
	378	scm_init_storage (0);
9ef3d0ee MD	379	scm_init_root ();
9ef3d0ee MD	380	#ifdef USE_THREADS
a239e35b	381	scm_init_threads (base);
9ef3d0ee	382	#endif
c275ddc7	383	scm_start_stack (base, in, out, err);
0f2d19dd JB	384	scm_init_gsubr ();
	385	scm_init_feature ();
	386	scm_init_alist ();
	387	scm_init_append ();
	388	scm_init_arbiters ();
	389	scm_init_async ();
	390	scm_init_boolean ();
	391	scm_init_chars ();
	392	scm_init_continuations ();
4e1caa79 MD	393	#ifdef DEBUG_EXTENSIONS
	394	scm_init_debug ();
	395	#endif
0f2d19dd JB	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 JB	427	scm_init_stackchk ();
0f2d19dd JB	428	scm_init_strports ();
0f2d19dd JB	429	scm_init_symbols ();
	430	scm_init_tag ();
	431	scm_init_load ();
90b826c9 MD	432	scm_init_struct ();
90b826c9 MD	433	scm_init_print (); /* Requires struct */
0f2d19dd JB	434	scm_init_read ();
	435	scm_init_sequences ();
	436	scm_init_stime ();
	437	scm_init_strings ();
	438	scm_init_strorder ();
	439	scm_init_mbstrings ();
	440	scm_init_strop ();
	441	scm_init_throw ();
	442	scm_init_variable ();
	443	scm_init_vectors ();
9d7e1edf	444	scm_init_version ();
0f2d19dd JB	445	scm_init_weaks ();
	446	scm_init_vports ();
	447	scm_init_eval ();
	448	scm_init_ramap ();
	449	scm_init_unif ();
	450	scm_init_simpos ();
0f2d19dd	451	scm_progargs = scm_makfromstrs (argc, argv);
24f93c27	452	scm_init_load_path ();
0f2d19dd JB	453	initialized = 1;
	454	}
	455
	456	scm_block_gc = 0; /* permit the gc to run */
	457	/* ints still disabled */
	458
	459	{
	460	SCM command;
	461
	462	command = scm_makfrom0str (boot_cmd);
	463
	464	setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont));
	465
faa6b3df MD	466	#ifdef STACK_CHECKING
	467	scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
	468	#endif
0f2d19dd JB	469	if (!setjmp_val)
0f2d19dd JB	470	{
3d40d7b6	471	SCM last = SCM_UNDEFINED;
0f2d19dd JB	472	scm_init_signals ();
0f2d19dd JB	473
47b44240 JB	474	/* Call the initialization function passed in by the user, if
	475	present. */
	476	if (init_func) (*init_func) ();
	477
	478	/* Evaluate boot_cmd string. */
0f2d19dd JB	479	{
	480	SCM p;
	481	SCM form;
	482
	483	p = scm_mkstrport (SCM_MAKINUM (0),
	484	command,
	485	SCM_OPN \| SCM_RDNG,
	486	"boot_guile");
	487	while (1)
	488	{
	489	form = scm_read (p, SCM_BOOL_F, SCM_BOOL_F);
	490	if (SCM_EOF_VAL == form)
	491	break;
	492	last = scm_eval_x (form);
	493	}
	494
	495	}
	496
	497	scm_restore_signals ();
	498	/* This tick gives any pending
	499	* asyncs a chance to run. This must be done after
	500	* the call to scm_restore_signals.
	501	*/
	502	SCM_ASYNC_TICK;
	503
	504	scm_ints_disabled = 1; /* Hopefully redundant but just to be sure. */
	505
	506	{
	507	SCM str_answer;
	508
	509	str_answer = scm_strprint_obj (last);
	510	result = (char )malloc (1 + SCM_LENGTH (str_answer));
	511	if (!*result)
	512	stat = scm_boot_emem;
	513	else
	514	{
	515	memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer));
	516	(*result)[SCM_LENGTH (str_answer)] = 0;
	517	stat = scm_boot_ok;
	518	}
	519	}
	520	}
	521	else
	522	{
	523	/* This is reached if an unhandled throw terminated Scheme.
	524	* Such an occurence should be extremely unlikely -- it indicates
	525	* a programming error in the boot code.
	526	*
	527	* Details of the bogus exception are stored in scm_exitval even
	528	* though that isn't currently reflected in the return value.
	529	* !!!
	530	*/
	531
	532	scm_restore_signals ();
	533	/* This tick gives any pending
	534	* asyncs a chance to run. This must be done after
	535	* the call to scm_restore_signals.
	536	*
	537	* Note that an unhandled exception during signal handling
	538	* will put as back at the call to scm_restore_signals immediately
	539	* preceeding. A sufficiently bogus signal handler could
	540	* conceivably cause an infinite loop here.
	541	*/
	542	SCM_ASYNC_TICK;
543
544	scm_ints_disabled = 1; /* Hopefully redundant but just to be sure. */
545
546	{
547	SCM str_answer;
548
549	str_answer = scm_strprint_obj (scm_exitval);
550	result = (char )malloc (1 + SCM_LENGTH (str_answer));
551	if (!*result)
552	stat = scm_boot_emem;
553	else
554	{
555	memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer));
556	(*result)[SCM_LENGTH (str_answer)] = 0;
557	stat = scm_boot_error;
558	}
559	}
560	}
561	}
562
563	scm_block_gc = 1;
564	live = 0;
565	return stat;
566	}