libguile/init.c

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