[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 ";

#ifdef __STDC__
static void 
fixconfig (char *s1, char *s2, int s)
#else
static void 
fixconfig (s1, s2, s)
     char *s1;
     char *s2;
     int s;
#endif
{
  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_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
	234	#ifdef __STDC__
	235	static void
	236	fixconfig (char s1, char s2, int s)
	237	#else
	238	static void
	239	fixconfig (s1, s2, s)
	240	char *s1;
	241	char *s2;
	242	int s;
	243	#endif
	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
	254
	255	static void
	256	check_config ()
	257	{
	258	scm_sizet j;
	259
	260	j = HEAP_SEG_SIZE;
	261	if (HEAP_SEG_SIZE != j)
	262	fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);
	263
	264	#ifdef SCM_SINGLES
	265	if (sizeof (float) != sizeof (long))
	266	fixconfig (remsg, "SCM_SINGLES", 0);
	267	#endif /* def SCM_SINGLES */
	268
	269
	270	#ifdef SCM_BIGDIG
	271	if (2 * SCM_BITSPERDIG / SCM_CHAR_BIT > sizeof (long))
	272	fixconfig (remsg, "SCM_BIGDIG", 0);
	273	#ifndef SCM_DIGSTOOBIG
	274	if (SCM_DIGSPERLONG * sizeof (SCM_BIGDIG) > sizeof (long))
	275	fixconfig (addmsg, "SCM_DIGSTOOBIG", 0);
	276	#endif
	277	#endif
	278
	279	#ifdef SCM_STACK_GROWS_UP
	280	if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0)
	281	fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
	282	#else
	283	if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0)
	284	fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1);
	285	#endif
	286	}
	287	#endif
	288
	289
	290	\f
291	#ifdef _UNICOS
292	typedef int setjmp_type;
293	#else
294	typedef long setjmp_type;
295	#endif
296
297	/* Fire up Scheme.
298	*
299	* argc and argv are made the return values of program-arguments.
300	*
301	* in, out, and err, if not NULL, become the standard ports.
47b44240	302	* If NULL is passed, your "initfunc" should set up the
0f2d19dd JB	303	* standard ports.
	304	*
	305	* boot_cmd is a string containing a Scheme expression to evaluate
	306	* to get things rolling.
	307	*
	308	* result is returned a string containing a printed result of evaluating
	309	* the boot command.
	310	*
	311	* the return value is:
	312	* scm_boot_ok - evaluation concluded normally
	313	* scm_boot_error - evaluation concluded with a Scheme error
	314	* scm_boot_emem - allocation error mallocing *result
47b44240 JB	315	* scm_boot_ereenter - scm_boot_guile was called re-entrantly, which is
47b44240 JB	316	* prohibited.
0f2d19dd JB	317	*/
0f2d19dd JB	318
c275ddc7 JB	319	static int scm_boot_guile_1 SCM_P ((SCM_STACKITEM *base,
	320	char **result,
	321	int argc, char **argv,
	322	FILE in, FILE out, FILE *err,
	323	void (*init_func) (),
	324	char *boot_cmd));
	325
0f2d19dd	326	int
47b44240	327	scm_boot_guile (result, argc, argv, in, out, err, init_func, boot_cmd)
0f2d19dd JB	328	char ** result;
	329	int argc;
	330	char ** argv;
	331	FILE * in;
	332	FILE * out;
	333	FILE * err;
47b44240	334	void (*init_func) ();
0f2d19dd	335	char * boot_cmd;
c275ddc7 JB	336	{
	337	SCM_STACKITEM dummy;
	338
	339	return scm_boot_guile_1 (&dummy, result, argc, argv, in, out, err,
	340	init_func, boot_cmd);
	341	}
	342
	343	static int
	344	scm_boot_guile_1 (base, result, argc, argv, in, out, err, init_func, boot_cmd)
	345	SCM_STACKITEM *base;
	346	char ** result;
	347	int argc;
	348	char ** argv;
	349	FILE * in;
	350	FILE * out;
	351	FILE * err;
	352	void (*init_func) ();
	353	char * boot_cmd;
0f2d19dd JB	354	{
	355	static int initialized = 0;
	356	static int live = 0;
0f2d19dd JB	357	setjmp_type setjmp_val;
	358	int stat;
	359
	360	if (live) /* This function is not re-entrant. */
	361	{
	362	return scm_boot_ereenter;
	363	}
	364
	365	live = 1;
	366
	367	scm_ints_disabled = 1;
	368	scm_block_gc = 1;
	369
	370	if (initialized)
	371	{
c275ddc7	372	scm_restart_stack (base);
0f2d19dd JB	373	}
	374	else
	375	{
	376	scm_ports_prehistory ();
	377	scm_smob_prehistory ();
	378	scm_tables_prehistory ();
	379	scm_init_storage (0);
9ef3d0ee MD	380	scm_init_root ();
9ef3d0ee MD	381	#ifdef USE_THREADS
a239e35b	382	scm_init_threads (base);
9ef3d0ee	383	#endif
c275ddc7	384	scm_start_stack (base, in, out, err);
0f2d19dd JB	385	scm_init_gsubr ();
	386	scm_init_feature ();
	387	scm_init_alist ();
	388	scm_init_append ();
	389	scm_init_arbiters ();
	390	scm_init_async ();
	391	scm_init_boolean ();
	392	scm_init_chars ();
	393	scm_init_continuations ();
4e1caa79 MD	394	#ifdef DEBUG_EXTENSIONS
	395	scm_init_debug ();
	396	#endif
0f2d19dd JB	397	scm_init_dynwind ();
	398	scm_init_eq ();
	399	scm_init_error ();
	400	scm_init_fdsocket ();
	401	scm_init_fports ();
0f2d19dd JB	402	scm_init_filesys ();
0f2d19dd JB	403	scm_init_gc ();
68cd9c71	404	scm_init_gdbint ();
0f2d19dd JB	405	scm_init_hash ();
	406	scm_init_hashtab ();
	407	scm_init_ioext ();
	408	scm_init_kw ();
	409	scm_init_list ();
	410	scm_init_mallocs ();
	411	scm_init_numbers ();
	412	scm_init_objprop ();
4e1caa79 MD	413	#if DEBUG_EXTENSIONS
	414	/* Excluding this until it's really needed makes the binary
	415	* smaller after linking. */
	416	scm_init_options ();
	417	#endif
0f2d19dd JB	418	scm_init_pairs ();
	419	scm_init_ports ();
	420	scm_init_posix ();
	421	scm_init_procs ();
	422	scm_init_procprop ();
0f2d19dd JB	423	scm_init_scmsigs ();
0f2d19dd JB	424	scm_init_socket ();
4e1caa79 MD	425	#ifdef DEBUG_EXTENSIONS
	426	scm_init_srcprop ();
	427	#endif
0f2d19dd JB	428	scm_init_stackchk ();
0f2d19dd JB	429	scm_init_strports ();
0f2d19dd JB	430	scm_init_symbols ();
	431	scm_init_tag ();
	432	scm_init_load ();
90b826c9 MD	433	scm_init_struct ();
90b826c9 MD	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 ();
	449	scm_init_ramap ();
	450	scm_init_unif ();
	451	scm_init_simpos ();
0f2d19dd	452	scm_progargs = scm_makfromstrs (argc, argv);
24f93c27	453	scm_init_load_path ();
0f2d19dd JB	454	initialized = 1;
	455	}
	456
	457	scm_block_gc = 0; /* permit the gc to run */
	458	/* ints still disabled */
	459
	460	{
	461	SCM command;
	462
	463	command = scm_makfrom0str (boot_cmd);
	464
	465	setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont));
	466
faa6b3df MD	467	#ifdef STACK_CHECKING
	468	scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
	469	#endif
0f2d19dd JB	470	if (!setjmp_val)
0f2d19dd JB	471	{
3d40d7b6	472	SCM last = SCM_UNDEFINED;
0f2d19dd JB	473	scm_init_signals ();
0f2d19dd JB	474
47b44240 JB	475	/* Call the initialization function passed in by the user, if
	476	present. */
	477	if (init_func) (*init_func) ();
	478
	479	/* Evaluate boot_cmd string. */
0f2d19dd JB	480	{
	481	SCM p;
	482	SCM form;
	483
	484	p = scm_mkstrport (SCM_MAKINUM (0),
	485	command,
	486	SCM_OPN \| SCM_RDNG,
	487	"boot_guile");
	488	while (1)
	489	{
	490	form = scm_read (p, SCM_BOOL_F, SCM_BOOL_F);
	491	if (SCM_EOF_VAL == form)
	492	break;
	493	last = scm_eval_x (form);
	494	}
	495
	496	}
	497
	498	scm_restore_signals ();
	499	/* This tick gives any pending
	500	* asyncs a chance to run. This must be done after
	501	* the call to scm_restore_signals.
	502	*/
	503	SCM_ASYNC_TICK;
	504
	505	scm_ints_disabled = 1; /* Hopefully redundant but just to be sure. */
	506
	507	{
	508	SCM str_answer;
	509
	510	str_answer = scm_strprint_obj (last);
	511	result = (char )malloc (1 + SCM_LENGTH (str_answer));
	512	if (!*result)
	513	stat = scm_boot_emem;
	514	else
	515	{
	516	memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer));
	517	(*result)[SCM_LENGTH (str_answer)] = 0;
	518	stat = scm_boot_ok;
	519	}
	520	}
	521	}
	522	else
	523	{
	524	/* This is reached if an unhandled throw terminated Scheme.
	525	* Such an occurence should be extremely unlikely -- it indicates
	526	* a programming error in the boot code.
	527	*
	528	* Details of the bogus exception are stored in scm_exitval even
	529	* though that isn't currently reflected in the return value.
	530	* !!!
	531	*/
	532
	533	scm_restore_signals ();
	534	/* This tick gives any pending
	535	* asyncs a chance to run. This must be done after
	536	* the call to scm_restore_signals.
	537	*
	538	* Note that an unhandled exception during signal handling
	539	* will put as back at the call to scm_restore_signals immediately
	540	* preceeding. A sufficiently bogus signal handler could
	541	* conceivably cause an infinite loop here.
	542	*/
	543	SCM_ASYNC_TICK;
544
545	scm_ints_disabled = 1; /* Hopefully redundant but just to be sure. */
546
547	{
548	SCM str_answer;
549
550	str_answer = scm_strprint_obj (scm_exitval);
551	result = (char )malloc (1 + SCM_LENGTH (str_answer));
552	if (!*result)
553	stat = scm_boot_emem;
554	else
555	{
556	memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer));
557	(*result)[SCM_LENGTH (str_answer)] = 0;
558	stat = scm_boot_error;
559	}
560	}
561	}
562	}
563
564	scm_block_gc = 1;
565	live = 0;
566	return stat;
567	}