libguile/init.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999, 2000 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, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46 /* Include the headers for just about everything.
  47    We call all their initialization functions.  */
  48
  49 #include <stdio.h>
  50 #include <sys/stat.h>
  51 #include <fcntl.h>
  52
  53 #include "libguile/_scm.h"
  54
  55 /* Everybody has an init function.  */
  56 #include "libguile/alist.h"
  57 #include "libguile/arbiters.h"
  58 #include "libguile/async.h"
  59 #include "libguile/backtrace.h"
  60 #include "libguile/boolean.h"
  61 #include "libguile/chars.h"
  62 #include "libguile/continuations.h"
  63 #ifdef DEBUG_EXTENSIONS
  64 #include "libguile/debug.h"
  65 #endif
  66 #ifdef GUILE_DEBUG_MALLOC
  67 #include "libguile/debug-malloc.h"
  68 #endif
  69 #include "libguile/dynl.h"
  70 #include "libguile/dynwind.h"
  71 #include "libguile/environments.h"
  72 #include "libguile/eq.h"
  73 #include "libguile/error.h"
  74 #include "libguile/eval.h"
  75 #include "libguile/evalext.h"
  76 #include "libguile/feature.h"
  77 #include "libguile/filesys.h"
  78 #include "libguile/fluids.h"
  79 #include "libguile/fports.h"
  80 #include "libguile/gc.h"
  81 #include "libguile/gdbint.h"
  82 #include "libguile/gsubr.h"
  83 #include "libguile/hash.h"
  84 #include "libguile/hashtab.h"
  85 #include "libguile/hooks.h"
  86 #ifdef GUILE_ISELECT
  87 #include "libguile/iselect.h"
  88 #endif
  89 #include "libguile/ioext.h"
  90 #include "libguile/keywords.h"
  91 #include "libguile/lang.h"
  92 #include "libguile/list.h"
  93 #include "libguile/load.h"
  94 #include "libguile/macros.h"
  95 #include "libguile/mallocs.h"
  96 #include "libguile/modules.h"
  97 #include "libguile/net_db.h"
  98 #include "libguile/numbers.h"
  99 #include "libguile/objects.h"
 100 #include "libguile/objprop.h"
 101 #include "libguile/options.h"
 102 #include "libguile/pairs.h"
 103 #include "libguile/ports.h"
 104 #include "libguile/posix.h"
 105 #ifdef HAVE_REGCOMP
 106 #include "libguile/regex-posix.h"
 107 #endif
 108 #include "libguile/print.h"
 109 #include "libguile/procprop.h"
 110 #include "libguile/procs.h"
 111 #include "libguile/ramap.h"
 112 #include "libguile/random.h"
 113 #include "libguile/read.h"
 114 #include "libguile/scmsigs.h"
 115 #include "libguile/script.h"
 116 #include "libguile/simpos.h"
 117 #include "libguile/smob.h"
 118 #include "libguile/socket.h"
 119 #include "libguile/sort.h"
 120 #include "libguile/srcprop.h"
 121 #include "libguile/stackchk.h"
 122 #include "libguile/stacks.h"
 123 #include "libguile/stime.h"
 124 #include "libguile/strings.h"
 125 #include "libguile/strop.h"
 126 #include "libguile/strorder.h"
 127 #include "libguile/strports.h"
 128 #include "libguile/struct.h"
 129 #include "libguile/symbols.h"
 130 #include "libguile/tag.h"
 131 #include "libguile/throw.h"
 132 #include "libguile/unif.h"
 133 #include "libguile/variable.h"
 134 #include "libguile/vectors.h"
 135 #include "libguile/version.h"
 136 #include "libguile/vports.h"
 137 #include "libguile/weaks.h"
 138 #include "libguile/guardians.h"
 139
 140 #include "libguile/init.h"
 141
 142 #ifdef HAVE_STRING_H
 143 #include <string.h>
 144 #endif
 145 #ifdef HAVE_UNISTD_H
 146 #include <unistd.h>
 147 #endif
 148 \f
 149 /* Setting up the stack.  */
 150
 151 static void
 152 restart_stack (void *base)
 153 {
 154   scm_dynwinds = SCM_EOL;
 155   SCM_DYNENV (scm_rootcont) = SCM_EOL;
 156   SCM_THROW_VALUE (scm_rootcont) = SCM_EOL;
 157 #ifdef DEBUG_EXTENSIONS
 158   SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
 159 #endif
 160   SCM_BASE (scm_rootcont) = base;
 161   scm_continuation_stack_ptr = SCM_MAKINUM (0);
 162 }
 163
 164 static void
 165 start_stack (void *base)
 166 {
 167   SCM root;
 168
 169   root = scm_permanent_object (scm_make_root (SCM_UNDEFINED));
 170   scm_set_root (SCM_ROOT_STATE (root));
 171   scm_stack_base = base;
 172
 173   scm_exitval = SCM_BOOL_F;     /* vestigial */
 174
 175 #if SCM_DEBUG_DEPRECATED == 0
 176   scm_top_level_lookup_closure_var = SCM_BOOL_F;
 177 #endif
 178   scm_system_transformer = SCM_BOOL_F;
 179
 180   scm_root->fluids = scm_make_initial_fluids ();
 181
 182   /* Create an object to hold the root continuation.
 183    */
 184   SCM_NEWCELL (scm_rootcont);
 185   SCM_SET_CONTREGS (scm_rootcont, scm_must_malloc (sizeof (scm_contregs),
 186                                                    "continuation"));
 187   SCM_SET_CELL_TYPE (scm_rootcont, scm_tc7_contin);
 188   SCM_SEQ (scm_rootcont) = 0;
 189   /* The root continuation if further initialized by restart_stack. */
 190
 191   /* Create the look-aside stack for variables that are shared between
 192    * captured continuations.
 193    */
 194   scm_continuation_stack = scm_make_vector (SCM_MAKINUM (512), SCM_UNDEFINED);
 195   /* The continuation stack is further initialized by restart_stack. */
 196
 197   /* The remainder of stack initialization is factored out to another
 198    * function so that if this stack is ever exitted, it can be
 199    * re-entered using restart_stack.  */
 200   restart_stack (base);
 201 }
 202
 203
 204 #if 0
 205 static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
 206
 207
 208 static void
 209 fixconfig (char *s1,char *s2,int s)
 210 {
 211   fputs (s1, stderr);
 212   fputs (s2, stderr);
 213   fputs ("\nin ", stderr);
 214   fputs (s ? "setjump" : "scmfig", stderr);
 215   fputs (".h and recompile scm\n", stderr);
 216   exit (1);
 217 }
 218
 219
 220 static void
 221 check_config (void)
 222 {
 223   scm_sizet j;
 224
 225   j = HEAP_SEG_SIZE;
 226   if (HEAP_SEG_SIZE != j)
 227     fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);
 228
 229 #ifdef SCM_BIGDIG
 230   if (2 * SCM_BITSPERDIG / SCM_CHAR_BIT > sizeof (long))
 231       fixconfig (remsg, "SCM_BIGDIG", 0);
 232 #ifndef SCM_DIGSTOOBIG
 233   if (SCM_DIGSPERLONG * sizeof (SCM_BIGDIG) > sizeof (long))
 234       fixconfig (addmsg, "SCM_DIGSTOOBIG", 0);
 235 #endif
 236 #endif
 237
 238 #ifdef SCM_STACK_GROWS_UP
 239   if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0)
 240     fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
 241 #else
 242   if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0)
 243     fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1);
 244 #endif
 245 }
 246 #endif
 247
 248
 249 \f
 250 /* initializing standard and current I/O ports */
 251
 252 typedef struct
 253 {
 254   int fdes;
 255   char *mode;
 256   char *name;
 257 } stream_body_data;
 258
 259 /* proc to be called in scope of exception handler stream_handler. */
 260 static SCM
 261 stream_body (void *data)
 262 {
 263   stream_body_data *body_data = (stream_body_data *) data;
 264   SCM port = scm_fdes_to_port (body_data->fdes, body_data->mode,
 265                                scm_makfrom0str (body_data->name));
 266
 267   SCM_REVEALED (port) = 1;
 268   return port;
 269 }
 270
 271 /* exception handler for stream_body.  */
 272 static SCM
 273 stream_handler (void *data, SCM tag, SCM throw_args)
 274 {
 275   return SCM_BOOL_F;
 276 }
 277
 278 /* Convert a file descriptor to a port, using scm_fdes_to_port.
 279    - NAME is a C string, not a Guile string
 280    - set the revealed count for FILE's file descriptor to 1, so
 281    that fdes won't be closed when the port object is GC'd.
 282    - catch exceptions: allow Guile to be able to start up even
 283    if it has been handed bogus stdin/stdout/stderr.  replace the
 284    bad ports with void ports.  */
 285 static SCM
 286 scm_standard_stream_to_port (int fdes, char *mode, char *name)
 287 {
 288   SCM port;
 289   stream_body_data body_data;
 290
 291   body_data.fdes = fdes;
 292   body_data.mode = mode;
 293   body_data.name = name;
 294   port = scm_internal_catch (SCM_BOOL_T, stream_body, &body_data,
 295                              stream_handler, NULL);
 296   if (SCM_FALSEP (port))
 297     port = scm_void_port (mode);
 298   return port;
 299 }
 300
 301 /* Create standard ports from stdin, stdout, and stderr.  */
 302 static void
 303 scm_init_standard_ports ()
 304 {
 305   /* From the SCSH manual:
 306
 307      It can be useful to turn I/O buffering off in some cases, for
 308      example when an I/O stream is to be shared by multiple
 309      subprocesses.  For this reason, scsh allocates an unbuffered port
 310      for file descriptor 0 at start-up time.
 311
 312      Because shells frequently share stdin with subprocesses, if the
 313      shell does buffered reads, it might ``steal'' input intended for
 314      a subprocess.  For this reason, all shells, including sh, csh,
 315      and scsh, read stdin unbuffered.  Applications that can tolerate
 316      buffered input on stdin can reset \ex{(current-input-port)} to
 317      block buffering for higher performance.  */
 318
 319   scm_def_inp
 320     = scm_standard_stream_to_port (0,
 321                                    isatty (0) ? "r0" : "r",
 322                                    "standard input");
 323   scm_def_outp = scm_standard_stream_to_port (1,
 324                                               isatty (1) ? "w0" : "w",
 325                                               "standard output");
 326   scm_def_errp = scm_standard_stream_to_port (2,
 327                                               isatty (2) ? "w0" : "w",
 328                                               "standard error");
 329
 330   scm_cur_inp = scm_def_inp;
 331   scm_cur_outp = scm_def_outp;
 332   scm_cur_errp = scm_def_errp;
 333   scm_cur_loadp = SCM_BOOL_F;
 334 }
 335
 336
 337 \f
 338 /* Loading the startup Scheme files.  */
 339
 340 /* The boot code "ice-9/boot-9" is only loaded by scm_boot_guile when
 341    this is false.  The unexec code uses this, to keep ice_9 from being
 342    loaded into dumped guile executables.  */
 343 int scm_ice_9_already_loaded = 0;
 344
 345 void
 346 scm_load_startup_files ()
 347 {
 348   /* We want a path only containing directories from GUILE_LOAD_PATH,
 349      SCM_SITE_DIR and SCM_LIBRARY_DIR when searching for the site init
 350      file, so we do this before loading Ice-9.  */
 351   SCM init_path = scm_sys_search_load_path (scm_makfrom0str ("init.scm"));
 352
 353   /* Load Ice-9.  */
 354   if (!scm_ice_9_already_loaded)
 355     {
 356       scm_primitive_load_path (scm_makfrom0str ("ice-9/boot-9.scm"));
 357
 358       /* Load the init.scm file.  */
 359       if (SCM_NFALSEP (init_path))
 360         scm_primitive_load (init_path);
 361
 362       scm_post_boot_init_modules ();
 363     }
 364 }
 365
 366 /* Get an integer from an environment variable.  */
 367 static int
 368 scm_i_getenv_int (const char *var, int def)
 369 {
 370   char *end, *val = getenv (var);
 371   long res;
 372   if (!val)
 373     return def;
 374   res = strtol (val, &end, 10);
 375   if (end == val)
 376     return def;
 377   return res;
 378 }
 379
 380 \f
 381 /* The main init code.  */
 382
 383 #ifdef _UNICOS
 384 typedef int setjmp_type;
 385 #else
 386 typedef long setjmp_type;
 387 #endif
 388
 389 /* All the data needed to invoke the main function.  */
 390 struct main_func_closure
 391 {
 392   /* the function to call */
 393   void (*main_func)(void *closure, int argc, char **argv);
 394   void *closure;                /* dummy data to pass it */
 395   int argc;
 396   char **argv;                  /* the argument list it should receive */
 397 };
 398
 399
 400 static void scm_boot_guile_1(SCM_STACKITEM *base, struct main_func_closure *closure);
 401 static SCM invoke_main_func(void *body_data);
 402
 403
 404 /* Fire up the Guile Scheme interpreter.
 405
 406    Call MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV.  MAIN_FUNC
 407    should do all the work of the program (initializing other packages,
 408    reading user input, etc.) before returning.  When MAIN_FUNC
 409    returns, call exit (0); this function never returns.  If you want
 410    some other exit value, MAIN_FUNC may call exit itself.
 411
 412    scm_boot_guile arranges for program-arguments to return the strings
 413    given by ARGC and ARGV.  If MAIN_FUNC modifies ARGC/ARGV, should
 414    call scm_set_program_arguments with the final list, so Scheme code
 415    will know which arguments have been processed.
 416
 417    scm_boot_guile establishes a catch-all catch handler which prints
 418    an error message and exits the process.  This means that Guile
 419    exits in a coherent way when system errors occur and the user isn't
 420    prepared to handle it.  If the user doesn't like this behavior,
 421    they can establish their own universal catcher to shadow this one.
 422
 423    Why must the caller do all the real work from MAIN_FUNC?  The
 424    garbage collector assumes that all local variables of type SCM will
 425    be above scm_boot_guile's stack frame on the stack.  If you try to
 426    manipulate SCM values after this function returns, it's the luck of
 427    the draw whether the GC will be able to find the objects you
 428    allocate.  So, scm_boot_guile function exits, rather than
 429    returning, to discourage people from making that mistake.  */
 430
 431
 432 void
 433 scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure)
 434 {
 435   /* The garbage collector uses the address of this variable as one
 436      end of the stack, and the address of one of its own local
 437      variables as the other end.  */
 438   SCM_STACKITEM dummy;
 439   struct main_func_closure c;
 440
 441   c.main_func = main_func;
 442   c.closure = closure;
 443   c.argc = argc;
 444   c.argv = argv;
 445
 446   scm_boot_guile_1 (&dummy, &c);
 447 }
 448
 449
 450 /* Record here whether SCM_BOOT_GUILE_1 has already been called.  This
 451    variable is now here and not inside SCM_BOOT_GUILE_1 so that one
 452    can tweak it. This is necessary for unexec to work. (Hey, "1-live"
 453    is the name of a local radiostation...) */
 454
 455 int scm_boot_guile_1_live = 0;
 456
 457 int scm_initialized_p = 0;
 458
 459 static void
 460 scm_boot_guile_1 (SCM_STACKITEM *base, struct main_func_closure *closure)
 461 {
 462   /* static int live = 0; */
 463   setjmp_type setjmp_val;
 464
 465   /* This function is not re-entrant. */
 466   if (scm_boot_guile_1_live)
 467     abort ();
 468
 469   scm_boot_guile_1_live = 1;
 470
 471   scm_ints_disabled = 1;
 472   scm_block_gc = 1;
 473
 474   if (scm_initialized_p)
 475     {
 476       restart_stack (base);
 477     }
 478   else
 479     {
 480       scm_ports_prehistory ();
 481       scm_smob_prehistory ();
 482       scm_tables_prehistory ();
 483 #ifdef GUILE_DEBUG_MALLOC
 484       scm_debug_malloc_prehistory ();
 485 #endif
 486       scm_init_storage (scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_1", 0),
 487                         scm_i_getenv_int ("GUILE_MIN_YIELD_1", 0),
 488                         scm_i_getenv_int ("GUILE_INIT_SEGMENT_SIZE_2", 0),
 489                         scm_i_getenv_int ("GUILE_MIN_YIELD_2", 0),
 490                         scm_i_getenv_int ("GUILE_MAX_SEGMENT_SIZE", 0));
 491       scm_struct_prehistory (); /* Must come after scm_init_storage */
 492       scm_weaks_prehistory ();  /* Must come after scm_init_storage */
 493       scm_init_subr_table ();
 494       scm_environments_prehistory (); /* create the root environment */
 495       scm_init_root ();
 496 #ifdef USE_THREADS
 497       scm_init_threads (base);
 498 #endif
 499       start_stack (base);
 500       scm_init_gsubr ();
 501       scm_init_environments ();
 502       scm_init_feature ();
 503       scm_init_alist ();
 504       scm_init_arbiters ();
 505       scm_init_async ();
 506       scm_init_boolean ();
 507       scm_init_chars ();
 508       scm_init_continuations ();
 509 #ifdef GUILE_DEBUG_MALLOC
 510       scm_init_debug_malloc ();
 511 #endif
 512       scm_init_dynwind ();
 513       scm_init_eq ();
 514       scm_init_error ();
 515       scm_init_fluids ();
 516       scm_init_backtrace ();    /* Requires fluids */
 517       scm_init_fports ();
 518       scm_init_gdbint ();
 519       scm_init_hash ();
 520       scm_init_hashtab ();
 521       scm_init_objprop ();
 522       scm_init_hooks ();        /* Requires objprop until hook names are removed */
 523       scm_init_gc ();           /* Requires hooks, async */
 524 #ifdef GUILE_ISELECT
 525       scm_init_iselect ();
 526 #endif
 527       scm_init_ioext ();
 528       scm_init_keywords ();
 529       scm_init_list ();
 530       scm_init_macros ();
 531       scm_init_mallocs ();
 532       scm_init_modules ();
 533       scm_init_numbers ();
 534       scm_init_options ();
 535       scm_init_pairs ();
 536       scm_init_ports ();
 537 #ifdef HAVE_POSIX
 538       scm_init_filesys ();
 539       scm_init_posix ();
 540 #endif
 541 #ifdef HAVE_REGCOMP
 542       scm_init_regex_posix ();
 543 #endif
 544       scm_init_procs ();
 545       scm_init_procprop ();
 546       scm_init_scmsigs ();
 547 #ifdef HAVE_NETWORKING
 548       scm_init_net_db ();
 549       scm_init_socket ();
 550 #endif
 551       scm_init_sort ();
 552 #ifdef DEBUG_EXTENSIONS
 553       scm_init_srcprop ();
 554 #endif
 555       scm_init_stackchk ();
 556       scm_init_struct ();       /* Requires struct */
 557       scm_init_stacks ();
 558       scm_init_strports ();
 559       scm_init_symbols ();
 560       scm_init_tag ();
 561       scm_init_load ();
 562       scm_init_objects ();      /* Requires struct */
 563       scm_init_print ();        /* Requires struct */
 564       scm_init_read ();
 565       scm_init_stime ();
 566       scm_init_strings ();
 567       scm_init_strorder ();
 568       scm_init_strop ();
 569       scm_init_throw ();
 570       scm_init_variable ();
 571       scm_init_vectors ();
 572       scm_init_version ();
 573       scm_init_weaks ();
 574       scm_init_guardian ();
 575       scm_init_vports ();
 576       scm_init_eval ();
 577       scm_init_evalext ();
 578 #ifdef DEBUG_EXTENSIONS
 579       scm_init_debug ();        /* Requires macro smobs */
 580 #endif
 581       scm_init_random ();
 582 #ifdef HAVE_ARRAYS
 583       scm_init_ramap ();
 584       scm_init_unif ();
 585 #endif
 586       scm_init_simpos ();
 587       scm_init_load_path ();
 588       scm_init_standard_ports ();
 589       scm_init_dynamic_linking ();
 590       scm_init_lang ();
 591       scm_init_script ();
 592       scm_initialized_p = 1;
 593     }
 594
 595   scm_block_gc = 0;             /* permit the gc to run */
 596   /* ints still disabled */
 597
 598 #ifdef STACK_CHECKING
 599   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 600 #endif
 601
 602   setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont));
 603   if (!setjmp_val)
 604     {
 605       scm_set_program_arguments (closure->argc, closure->argv, 0);
 606       scm_internal_lazy_catch (SCM_BOOL_T, invoke_main_func, closure,
 607                                scm_handle_by_message, 0);
 608     }
 609
 610   scm_restore_signals ();
 611
 612   /* This tick gives any pending
 613    * asyncs a chance to run.  This must be done after
 614    * the call to scm_restore_signals.
 615    */
 616   SCM_ASYNC_TICK;
 617
 618   /* If the caller doesn't want this, they should return from
 619      main_func themselves.  */
 620   exit (0);
 621 }
 622
 623
 624 static SCM
 625 invoke_main_func (void *body_data)
 626 {
 627   struct main_func_closure *closure = (struct main_func_closure *) body_data;
 628
 629   scm_load_startup_files ();
 630
 631   (*closure->main_func) (closure->closure, closure->argc, closure->argv);
 632
 633   /* never reached */
 634   return SCM_UNDEFINED;
 635 }
 636
 637 /*
 638   Local Variables:
 639   c-file-style: "gnu"
 640   End:
 641 */