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