libguile/init.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003, 2004, 2006 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library 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 GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18
  19 \f
  20 /* Include the headers for just about everything.
  21    We call all their initialization functions.  */
  22
  23 #ifdef HAVE_CONFIG_H
  24 #  include <config.h>
  25 #endif
  26
  27 #include <stdio.h>
  28 #include <sys/stat.h>
  29 #include <fcntl.h>
  30 #include <gmp.h>
  31
  32 #include "libguile/_scm.h"
  33
  34 /* Everybody has an init function.  */
  35 #include "libguile/alist.h"
  36 #include "libguile/arbiters.h"
  37 #include "libguile/async.h"
  38 #include "libguile/backtrace.h"
  39 #include "libguile/boolean.h"
  40 #include "libguile/chars.h"
  41 #include "libguile/continuations.h"
  42 #include "libguile/debug.h"
  43 #ifdef GUILE_DEBUG_MALLOC
  44 #include "libguile/debug-malloc.h"
  45 #endif
  46 #include "libguile/deprecation.h"
  47 #include "libguile/dynl.h"
  48 #include "libguile/dynwind.h"
  49 #if 0
  50 #include "libguile/environments.h"
  51 #endif
  52 #include "libguile/eq.h"
  53 #include "libguile/error.h"
  54 #include "libguile/eval.h"
  55 #include "libguile/evalext.h"
  56 #include "libguile/feature.h"
  57 #include "libguile/filesys.h"
  58 #include "libguile/fluids.h"
  59 #include "libguile/fports.h"
  60 #include "libguile/futures.h"
  61 #include "libguile/gc.h"
  62 #include "libguile/gdbint.h"
  63 #include "libguile/goops.h"
  64 #include "libguile/gsubr.h"
  65 #include "libguile/hash.h"
  66 #include "libguile/hashtab.h"
  67 #include "libguile/hooks.h"
  68 #include "libguile/gettext.h"
  69 #include "libguile/iselect.h"
  70 #include "libguile/ioext.h"
  71 #include "libguile/keywords.h"
  72 #include "libguile/lang.h"
  73 #include "libguile/list.h"
  74 #include "libguile/load.h"
  75 #include "libguile/macros.h"
  76 #include "libguile/mallocs.h"
  77 #include "libguile/modules.h"
  78 #include "libguile/net_db.h"
  79 #include "libguile/numbers.h"
  80 #include "libguile/objects.h"
  81 #include "libguile/objprop.h"
  82 #include "libguile/options.h"
  83 #include "libguile/pairs.h"
  84 #include "libguile/ports.h"
  85 #include "libguile/posix.h"
  86 #ifdef HAVE_REGCOMP
  87 #include "libguile/regex-posix.h"
  88 #endif
  89 #include "libguile/print.h"
  90 #include "libguile/procprop.h"
  91 #include "libguile/procs.h"
  92 #include "libguile/properties.h"
  93 #include "libguile/ramap.h"
  94 #include "libguile/random.h"
  95 #include "libguile/rdelim.h"
  96 #include "libguile/read.h"
  97 #include "libguile/rw.h"
  98 #include "libguile/scmsigs.h"
  99 #include "libguile/script.h"
 100 #include "libguile/simpos.h"
 101 #include "libguile/smob.h"
 102 #include "libguile/socket.h"
 103 #include "libguile/sort.h"
 104 #include "libguile/srcprop.h"
 105 #include "libguile/stackchk.h"
 106 #include "libguile/stacks.h"
 107 #include "libguile/stime.h"
 108 #include "libguile/strings.h"
 109 #include "libguile/srfi-13.h"
 110 #include "libguile/srfi-14.h"
 111 #include "libguile/strorder.h"
 112 #include "libguile/strports.h"
 113 #include "libguile/struct.h"
 114 #include "libguile/symbols.h"
 115 #include "libguile/throw.h"
 116 #include "libguile/unif.h"
 117 #include "libguile/values.h"
 118 #include "libguile/variable.h"
 119 #include "libguile/vectors.h"
 120 #include "libguile/version.h"
 121 #include "libguile/vm-bootstrap.h"
 122 #include "libguile/vports.h"
 123 #include "libguile/weaks.h"
 124 #include "libguile/guardians.h"
 125 #include "libguile/extensions.h"
 126 #include "libguile/srfi-4.h"
 127 #include "libguile/discouraged.h"
 128 #include "libguile/deprecated.h"
 129
 130 #include "libguile/init.h"
 131 #include "libguile/private-options.h"
 132
 133 #ifdef HAVE_STRING_H
 134 #include <string.h>
 135 #endif
 136 #ifdef HAVE_UNISTD_H
 137 #include <unistd.h>
 138 #endif
 139 \f
 140
 141
 142 #if 0
 143 static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
 144
 145
 146 static void
 147 fixconfig (char *s1, char *s2, int s)
 148 {
 149   fputs (s1, stderr);
 150   fputs (s2, stderr);
 151   fputs ("\nin ", stderr);
 152   fputs (s ? "setjump" : "scmfig", stderr);
 153   fputs (".h and recompile scm\n", stderr);
 154   exit (1);
 155 }
 156
 157
 158 static void
 159 check_config (void)
 160 {
 161   size_t j;
 162
 163   j = HEAP_SEG_SIZE;
 164   if (HEAP_SEG_SIZE != j)
 165     fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);
 166
 167 #if SCM_STACK_GROWS_UP
 168   if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0)
 169     fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
 170 #else
 171   if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0)
 172     fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1);
 173 #endif
 174 }
 175 #endif
 176
 177
 178 \f
 179 /* initializing standard and current I/O ports */
 180
 181 typedef struct
 182 {
 183   int fdes;
 184   char *mode;
 185   char *name;
 186 } stream_body_data;
 187
 188 /* proc to be called in scope of exception handler stream_handler. */
 189 static SCM
 190 stream_body (void *data)
 191 {
 192   stream_body_data *body_data = (stream_body_data *) data;
 193   SCM port = scm_fdes_to_port (body_data->fdes, body_data->mode,
 194                                scm_from_locale_string (body_data->name));
 195
 196   SCM_REVEALED (port) = 1;
 197   return port;
 198 }
 199
 200 /* exception handler for stream_body.  */
 201 static SCM
 202 stream_handler (void *data SCM_UNUSED,
 203                 SCM tag SCM_UNUSED,
 204                 SCM throw_args SCM_UNUSED)
 205 {
 206   return SCM_BOOL_F;
 207 }
 208
 209 /* Convert a file descriptor to a port, using scm_fdes_to_port.
 210    - NAME is a C string, not a Guile string
 211    - set the revealed count for FILE's file descriptor to 1, so
 212    that fdes won't be closed when the port object is GC'd.
 213    - catch exceptions: allow Guile to be able to start up even
 214    if it has been handed bogus stdin/stdout/stderr.  replace the
 215    bad ports with void ports.  */
 216 static SCM
 217 scm_standard_stream_to_port (int fdes, char *mode, char *name)
 218 {
 219   SCM port;
 220   stream_body_data body_data;
 221
 222   body_data.fdes = fdes;
 223   body_data.mode = mode;
 224   body_data.name = name;
 225   port = scm_internal_catch (SCM_BOOL_T, stream_body, &body_data,
 226                              stream_handler, NULL);
 227   if (scm_is_false (port))
 228     port = scm_void_port (mode);
 229   return port;
 230 }
 231
 232 /* Create standard ports from stdin, stdout, and stderr.  */
 233 static void
 234 scm_init_standard_ports ()
 235 {
 236   /* From the SCSH manual:
 237
 238      It can be useful to turn I/O buffering off in some cases, for
 239      example when an I/O stream is to be shared by multiple
 240      subprocesses.  For this reason, scsh allocates an unbuffered port
 241      for file descriptor 0 at start-up time.
 242
 243      Because shells frequently share stdin with subprocesses, if the
 244      shell does buffered reads, it might ``steal'' input intended for
 245      a subprocess.  For this reason, all shells, including sh, csh,
 246      and scsh, read stdin unbuffered.  Applications that can tolerate
 247      buffered input on stdin can reset \ex{(current-input-port)} to
 248      block buffering for higher performance.  */
 249
 250   scm_set_current_input_port
 251     (scm_standard_stream_to_port (0,
 252                                   isatty (0) ? "r0" : "r",
 253                                   "standard input"));
 254   scm_set_current_output_port
 255     (scm_standard_stream_to_port (1,
 256                                   isatty (1) ? "w0" : "w",
 257                                   "standard output"));
 258   scm_set_current_error_port
 259     (scm_standard_stream_to_port (2,
 260                                   isatty (2) ? "w0" : "w",
 261                                   "standard error"));
 262 }
 263
 264
 265 \f
 266 /* Loading the startup Scheme files.  */
 267
 268 /* The boot code "ice-9/boot-9" is only loaded by scm_boot_guile when
 269    this is false.  The unexec code uses this, to keep ice_9 from being
 270    loaded into dumped guile executables.  */
 271 int scm_ice_9_already_loaded = 0;
 272
 273 void
 274 scm_load_startup_files ()
 275 {
 276   /* We want a path only containing directories from GUILE_LOAD_PATH,
 277      SCM_SITE_DIR and SCM_LIBRARY_DIR when searching for the site init
 278      file, so we do this before loading Ice-9.  */
 279   SCM init_path =
 280     scm_sys_search_load_path (scm_from_locale_string ("init.scm"));
 281
 282   /* Load Ice-9.  */
 283   if (!scm_ice_9_already_loaded)
 284     {
 285       scm_primitive_load_path (scm_from_locale_string ("ice-9/boot-9"));
 286
 287       /* Load the init.scm file.  */
 288       if (scm_is_true (init_path))
 289         scm_primitive_load (init_path);
 290     }
 291 }
 292
 293 \f
 294 /* The main init code.  */
 295
 296 #ifdef _UNICOS
 297 typedef int setjmp_type;
 298 #else
 299 typedef long setjmp_type;
 300 #endif
 301
 302 /* All the data needed to invoke the main function.  */
 303 struct main_func_closure
 304 {
 305   /* the function to call */
 306   void (*main_func)(void *closure, int argc, char **argv);
 307   void *closure;                /* dummy data to pass it */
 308   int argc;
 309   char **argv;                  /* the argument list it should receive */
 310 };
 311
 312 static void *invoke_main_func(void *body_data);
 313
 314
 315 /* Fire up the Guile Scheme interpreter.
 316
 317    Call MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV.  MAIN_FUNC
 318    should do all the work of the program (initializing other packages,
 319    reading user input, etc.) before returning.  When MAIN_FUNC
 320    returns, call exit (0); this function never returns.  If you want
 321    some other exit value, MAIN_FUNC may call exit itself.
 322
 323    scm_boot_guile arranges for program-arguments to return the strings
 324    given by ARGC and ARGV.  If MAIN_FUNC modifies ARGC/ARGV, should
 325    call scm_set_program_arguments with the final list, so Scheme code
 326    will know which arguments have been processed.
 327
 328    scm_boot_guile establishes a catch-all catch handler which prints
 329    an error message and exits the process.  This means that Guile
 330    exits in a coherent way when system errors occur and the user isn't
 331    prepared to handle it.  If the user doesn't like this behavior,
 332    they can establish their own universal catcher to shadow this one.
 333
 334    Why must the caller do all the real work from MAIN_FUNC?  The
 335    garbage collector assumes that all local variables of type SCM will
 336    be above scm_boot_guile's stack frame on the stack.  If you try to
 337    manipulate SCM values after this function returns, it's the luck of
 338    the draw whether the GC will be able to find the objects you
 339    allocate.  So, scm_boot_guile function exits, rather than
 340    returning, to discourage people from making that mistake.  */
 341
 342
 343 void
 344 scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure)
 345 {
 346   void *res;
 347   struct main_func_closure c;
 348
 349   c.main_func = main_func;
 350   c.closure = closure;
 351   c.argc = argc;
 352   c.argv = argv;
 353
 354   res = scm_with_guile (invoke_main_func, &c);
 355
 356   /* If the caller doesn't want this, they should exit from main_func
 357      themselves.
 358   */
 359   if (res == NULL)
 360     exit (EXIT_FAILURE);
 361   else
 362     exit (0);
 363 }
 364
 365 static void *
 366 invoke_main_func (void *body_data)
 367 {
 368   struct main_func_closure *closure = (struct main_func_closure *) body_data;
 369
 370   scm_set_program_arguments (closure->argc, closure->argv, 0);
 371   (*closure->main_func) (closure->closure, closure->argc, closure->argv);
 372
 373   scm_restore_signals ();
 374
 375   /* This tick gives any pending
 376    * asyncs a chance to run.  This must be done after
 377    * the call to scm_restore_signals.
 378    */
 379   SCM_ASYNC_TICK;
 380
 381   /* Indicate success by returning non-NULL.
 382    */
 383   return (void *)1;
 384 }
 385
 386 scm_i_pthread_mutex_t scm_i_init_mutex = SCM_I_PTHREAD_MUTEX_INITIALIZER;
 387 int scm_initialized_p = 0;
 388
 389 static void *
 390 really_cleanup_for_exit (void *unused)
 391 {
 392   scm_flush_all_ports ();
 393   return NULL;
 394 }
 395
 396 static void
 397 cleanup_for_exit ()
 398 {
 399   if (scm_i_pthread_mutex_trylock (&scm_i_init_mutex) == 0)
 400     scm_i_pthread_mutex_unlock (&scm_i_init_mutex);
 401   else
 402     {
 403       fprintf (stderr, "Cannot exit gracefully when init is in progress; aborting.\n");
 404       abort ();
 405     }
 406
 407   /* This function might be called in non-guile mode, so we need to
 408      enter it temporarily.
 409   */
 410   scm_with_guile (really_cleanup_for_exit, NULL);
 411 }
 412
 413 void
 414 scm_i_init_guile (SCM_STACKITEM *base)
 415 {
 416   if (scm_initialized_p)
 417     return;
 418
 419   if (base == NULL)
 420     {
 421       fprintf (stderr, "cannot determine stack base!\n");
 422       abort ();
 423     }
 424
 425   if (sizeof (mpz_t) > (3 * sizeof (scm_t_bits)))
 426     {
 427       fprintf (stderr,
 428                "GMP's mpz_t must fit into a double_cell,"
 429                "but doesn't seem to here.\n");
 430     }
 431
 432   scm_storage_prehistory ();
 433   scm_threads_prehistory (base);
 434   scm_ports_prehistory ();
 435   scm_smob_prehistory ();
 436   scm_fluids_prehistory ();
 437   scm_hashtab_prehistory ();    /* requires storage_prehistory */
 438 #ifdef GUILE_DEBUG_MALLOC
 439   scm_debug_malloc_prehistory ();
 440 #endif
 441   if (scm_init_storage ())        /* requires threads_prehistory,
 442                                      smob_prehistory and
 443                                      hashtab_prehistory */
 444     abort ();
 445
 446   scm_struct_prehistory ();       /* requires storage */
 447   scm_symbols_prehistory ();      /* requires storage */
 448   scm_init_subr_table ();
 449 #if 0
 450   scm_environments_prehistory (); /* requires storage */
 451 #endif
 452   scm_modules_prehistory ();      /* requires storage and hash tables */
 453   scm_init_variable ();           /* all bindings need variables */
 454   scm_init_continuations ();
 455   scm_init_root ();               /* requires continuations */
 456   scm_init_threads ();            /* requires fluids */
 457   scm_init_gsubr ();
 458   scm_init_thread_procs ();       /* requires gsubrs */
 459   scm_init_procprop ();
 460 #if 0
 461   scm_init_environments ();
 462 #endif
 463   scm_init_alist ();
 464   scm_init_arbiters ();
 465   scm_init_async ();
 466   scm_init_boolean ();
 467   scm_init_chars ();
 468 #ifdef GUILE_DEBUG_MALLOC
 469   scm_init_debug_malloc ();
 470 #endif
 471   scm_init_dynwind ();
 472   scm_init_eq ();
 473   scm_init_error ();
 474 #if 0
 475   /* See futures.h for a comment why futures are not enabled.
 476    */
 477   scm_init_futures ();
 478 #endif
 479   scm_init_fluids ();
 480   scm_init_feature ();          /* Requires fluids */
 481   scm_init_backtrace ();        /* Requires fluids */
 482   scm_init_fports ();
 483   scm_init_strports ();
 484   scm_init_ports ();
 485   scm_init_gdbint ();           /* Requires strports */
 486   scm_init_hash ();
 487   scm_init_hashtab ();
 488   scm_init_deprecation ();      /* Requires hashtabs */
 489   scm_init_objprop ();
 490   scm_init_properties ();
 491   scm_init_hooks ();            /* Requires smob_prehistory */
 492   scm_init_gc ();               /* Requires hooks, async */
 493   scm_init_gettext ();
 494   scm_init_ioext ();
 495   scm_init_keywords ();
 496   scm_init_list ();
 497   scm_init_macros ();
 498   scm_init_mallocs ();
 499   scm_init_modules ();
 500   scm_init_numbers ();
 501   scm_init_options ();
 502   scm_init_pairs ();
 503 #ifdef HAVE_POSIX
 504   scm_init_filesys ();
 505   scm_init_posix ();
 506 #endif
 507 #ifdef HAVE_REGCOMP
 508   scm_init_regex_posix ();
 509 #endif
 510   scm_init_procs ();
 511   scm_init_scmsigs ();
 512 #ifdef HAVE_NETWORKING
 513   scm_init_net_db ();
 514   scm_init_socket ();
 515 #endif
 516   scm_init_sort ();
 517   scm_init_srcprop ();
 518   scm_init_stackchk ();
 519   scm_init_strings ();
 520   scm_init_struct ();   /* Requires strings */
 521   scm_init_stacks ();   /* Requires strings, struct */
 522   scm_init_symbols ();
 523   scm_init_values ();   /* Requires struct */
 524   scm_init_load ();     /* Requires strings */
 525   scm_init_objects ();  /* Requires struct */
 526   scm_init_print ();    /* Requires strings, struct */
 527   scm_init_read ();
 528   scm_init_stime ();
 529   scm_init_strorder ();
 530   scm_init_srfi_13 ();
 531   scm_init_srfi_14 ();
 532   scm_init_throw ();
 533   scm_init_vectors ();
 534   scm_init_version ();
 535   scm_init_weaks ();
 536   scm_init_guardians ();
 537   scm_init_vports ();
 538   scm_init_eval ();
 539   scm_init_evalext ();
 540   scm_init_debug ();    /* Requires macro smobs */
 541   scm_init_random ();
 542   scm_init_ramap ();
 543   scm_init_unif ();
 544   scm_init_simpos ();
 545   scm_init_load_path ();
 546   scm_init_standard_ports ();  /* Requires fports */
 547   scm_init_dynamic_linking ();
 548 #if SCM_ENABLE_ELISP
 549   scm_init_lang ();
 550 #endif /* SCM_ENABLE_ELISP */
 551   scm_init_script ();
 552   scm_init_srfi_4 ();
 553
 554   scm_init_goops ();
 555
 556 #if SCM_ENABLE_DISCOURAGED == 1
 557   scm_i_init_discouraged ();
 558 #endif
 559
 560 #if SCM_ENABLE_DEPRECATED == 1
 561   scm_i_init_deprecated ();
 562 #endif
 563
 564   scm_init_threads_default_dynamic_state ();
 565
 566   scm_initialized_p = 1;
 567
 568 #ifdef STACK_CHECKING
 569   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 570 #endif
 571
 572   scm_init_rdelim ();
 573   scm_init_rw ();
 574   scm_init_extensions ();
 575
 576   scm_bootstrap_vm ();
 577
 578   atexit (cleanup_for_exit);
 579   scm_load_startup_files ();
 580 }
 581
 582 /*
 583   Local Variables:
 584   c-file-style: "gnu"
 585   End:
 586 */