diff options
Diffstat (limited to 'libguile/init.c')
-rw-r--r-- | libguile/init.c | 453 |
1 files changed, 453 insertions, 0 deletions
diff --git a/libguile/init.c b/libguile/init.c new file mode 100644 index 000000000..2f65c15f6 --- /dev/null +++ b/libguile/init.c @@ -0,0 +1,453 @@ +/* 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. + */ + + +#include <stdio.h> +#include "_scm.h" + + + +#ifdef __STDC__ +void +scm_start_stack (void * base, FILE * in, FILE * out, FILE * err) +#else +void +scm_start_stack (base, in, out, err) + void * base; + FILE * in; + FILE * out; + FILE * err; +#endif +{ + struct scm_port_table * pt; + + scm_stack_base = base; + + /* Create standar 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; + /* 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); +} + + +#ifdef __STDC__ +void +scm_restart_stack (void * base) +#else +void +scm_restart_stack (base) + void * base; +#endif +{ + scm_dynwinds = SCM_EOL; + SCM_DYNENV (scm_rootcont) = SCM_EOL; + SCM_THROW_VALUE (scm_rootcont) = SCM_EOL; + 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 + + + +#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 "scm_appinit" 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. + */ + +#ifdef __STDC__ +int +scm_boot_guile (char ** result, int argc, char ** argv, FILE * in, FILE * out, FILE * err, char * boot_cmd) +#else +int +scm_boot_guile (result, argc, argv, in, out, err, boot_cmd) + char ** result; + int argc; + char ** argv; + FILE * in; + FILE * out; + FILE * err; + char * boot_cmd; +#endif +{ + static int initialized = 0; + static int live = 0; + SCM_STACKITEM i; + 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 (&i); + } + else + { + scm_ports_prehistory (); + scm_smob_prehistory (); + scm_tables_prehistory (); + scm_init_storage (0); + scm_start_stack (&i, 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 (); + scm_init_dynwind (); + scm_init_eq (); + scm_init_error (); + scm_init_fdsocket (); + scm_init_fports (); + scm_init_files (); + scm_init_filesys (); + scm_init_gc (); + scm_init_hash (); + scm_init_hashtab (); + scm_init_ioext (); + scm_init_kw (); + scm_init_list (); + scm_init_mallocs (); + scm_init_numbers (); + scm_init_objprop (); + scm_init_pairs (); + scm_init_ports (); + scm_init_posix (); + scm_init_procs (); + scm_init_procprop (); + scm_init_rgx (); + scm_init_scmsigs (); + scm_init_socket (); + scm_init_stackchk (); + scm_init_strports (); + scm_init_struct (); + scm_init_symbols (); + scm_init_tag (); + scm_init_load (); + scm_init_print (); + 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_weaks (); + scm_init_vports (); + scm_init_eval (); + scm_init_ramap (); + scm_init_unif (); + scm_init_simpos (); + scm_appinit (); + scm_progargs = scm_makfromstrs (argc, argv); + 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)); + + if (!setjmp_val) + { + SCM last; + scm_init_signals (); + + { + 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; +} |