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