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