libguile/init.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2002, 2003 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 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
  31 #include "libguile/_scm.h"
  32
  33 /* Everybody has an init function.  */
  34 #include "libguile/alist.h"
  35 #include "libguile/arbiters.h"
  36 #include "libguile/async.h"
  37 #include "libguile/backtrace.h"
  38 #include "libguile/boolean.h"
  39 #include "libguile/chars.h"
  40 #include "libguile/continuations.h"
  41 #ifdef DEBUG_EXTENSIONS
  42 #include "libguile/debug.h"
  43 #endif
  44 #ifdef GUILE_DEBUG_MALLOC
  45 #include "libguile/debug-malloc.h"
  46 #endif
  47 #include "libguile/deprecation.h"
  48 #include "libguile/dynl.h"
  49 #include "libguile/dynwind.h"
  50 #include "libguile/environments.h"
  51 #include "libguile/eq.h"
  52 #include "libguile/error.h"
  53 #include "libguile/eval.h"
  54 #include "libguile/evalext.h"
  55 #include "libguile/feature.h"
  56 #include "libguile/filesys.h"
  57 #include "libguile/fluids.h"
  58 #include "libguile/fports.h"
  59 #include "libguile/futures.h"
  60 #include "libguile/gc.h"
  61 #include "libguile/gdbint.h"
  62 #include "libguile/goops.h"
  63 #include "libguile/gsubr.h"
  64 #include "libguile/hash.h"
  65 #include "libguile/hashtab.h"
  66 #include "libguile/hooks.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/strop.h"
 108 #include "libguile/strorder.h"
 109 #include "libguile/strports.h"
 110 #include "libguile/struct.h"
 111 #include "libguile/symbols.h"
 112 #include "libguile/throw.h"
 113 #include "libguile/unif.h"
 114 #include "libguile/values.h"
 115 #include "libguile/variable.h"
 116 #include "libguile/vectors.h"
 117 #include "libguile/version.h"
 118 #include "libguile/vports.h"
 119 #include "libguile/weaks.h"
 120 #include "libguile/guardians.h"
 121 #include "libguile/extensions.h"
 122 #include "libguile/deprecated.h"
 123
 124 #include "libguile/init.h"
 125
 126 #ifdef HAVE_STRING_H
 127 #include <string.h>
 128 #endif
 129 #ifdef HAVE_UNISTD_H
 130 #include <unistd.h>
 131 #endif
 132 \f
 133 /* Setting up the stack.  */
 134
 135 static void
 136 restart_stack (void *base)
 137 {
 138   scm_dynwinds = SCM_EOL;
 139   SCM_DYNENV (scm_rootcont) = SCM_EOL;
 140   SCM_THROW_VALUE (scm_rootcont) = SCM_EOL;
 141 #ifdef DEBUG_EXTENSIONS
 142   SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
 143 #endif
 144   SCM_BASE (scm_rootcont) = base;
 145 }
 146
 147 static void
 148 start_stack (void *base)
 149 {
 150   SCM root;
 151
 152   root = scm_permanent_object (scm_make_root (SCM_UNDEFINED));
 153   scm_set_root (SCM_ROOT_STATE (root));
 154   scm_stack_base = base;
 155
 156   scm_exitval = SCM_BOOL_F;     /* vestigial */
 157
 158   scm_root->fluids = scm_make_initial_fluids ();
 159
 160   /* Create an object to hold the root continuation.
 161    */
 162   {
 163     scm_t_contregs *contregs = scm_gc_malloc (sizeof (scm_t_contregs),
 164                                               "continuation");
 165     contregs->num_stack_items = 0;
 166     contregs->seq = 0;
 167     SCM_NEWSMOB (scm_rootcont, scm_tc16_continuation, contregs);
 168   }
 169
 170   /* The remainder of stack initialization is factored out to another
 171    * function so that if this stack is ever exitted, it can be
 172    * re-entered using restart_stack.  */
 173   restart_stack (base);
 174 }
 175
 176
 177 #if 0
 178 static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
 179
 180
 181 static void
 182 fixconfig (char *s1, char *s2, int s)
 183 {
 184   fputs (s1, stderr);
 185   fputs (s2, stderr);
 186   fputs ("\nin ", stderr);
 187   fputs (s ? "setjump" : "scmfig", stderr);
 188   fputs (".h and recompile scm\n", stderr);
 189   exit (1);
 190 }
 191
 192
 193 static void
 194 check_config (void)
 195 {
 196   size_t j;
 197
 198   j = HEAP_SEG_SIZE;
 199   if (HEAP_SEG_SIZE != j)
 200     fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);
 201
 202 #if SCM_STACK_GROWS_UP
 203   if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0)
 204     fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
 205 #else
 206   if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0)
 207     fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1);
 208 #endif
 209 }
 210 #endif
 211
 212
 213 \f
 214 /* initializing standard and current I/O ports */
 215
 216 typedef struct
 217 {
 218   int fdes;
 219   char *mode;
 220   char *name;
 221 } stream_body_data;
 222
 223 /* proc to be called in scope of exception handler stream_handler. */
 224 static SCM
 225 stream_body (void *data)
 226 {
 227   stream_body_data *body_data = (stream_body_data *) data;
 228   SCM port = scm_fdes_to_port (body_data->fdes, body_data->mode,
 229                                scm_makfrom0str (body_data->name));
 230
 231   SCM_REVEALED (port) = 1;
 232   return port;
 233 }
 234
 235 /* exception handler for stream_body.  */
 236 static SCM
 237 stream_handler (void *data SCM_UNUSED,
 238                 SCM tag SCM_UNUSED,
 239                 SCM throw_args SCM_UNUSED)
 240 {
 241   return SCM_BOOL_F;
 242 }
 243
 244 /* Convert a file descriptor to a port, using scm_fdes_to_port.
 245    - NAME is a C string, not a Guile string
 246    - set the revealed count for FILE's file descriptor to 1, so
 247    that fdes won't be closed when the port object is GC'd.
 248    - catch exceptions: allow Guile to be able to start up even
 249    if it has been handed bogus stdin/stdout/stderr.  replace the
 250    bad ports with void ports.  */
 251 static SCM
 252 scm_standard_stream_to_port (int fdes, char *mode, char *name)
 253 {
 254   SCM port;
 255   stream_body_data body_data;
 256
 257   body_data.fdes = fdes;
 258   body_data.mode = mode;
 259   body_data.name = name;
 260   port = scm_internal_catch (SCM_BOOL_T, stream_body, &body_data,
 261                              stream_handler, NULL);
 262   if (SCM_FALSEP (port))
 263     port = scm_void_port (mode);
 264   return port;
 265 }
 266
 267 /* Create standard ports from stdin, stdout, and stderr.  */
 268 static void
 269 scm_init_standard_ports ()
 270 {
 271   /* From the SCSH manual:
 272
 273      It can be useful to turn I/O buffering off in some cases, for
 274      example when an I/O stream is to be shared by multiple
 275      subprocesses.  For this reason, scsh allocates an unbuffered port
 276      for file descriptor 0 at start-up time.
 277
 278      Because shells frequently share stdin with subprocesses, if the
 279      shell does buffered reads, it might ``steal'' input intended for
 280      a subprocess.  For this reason, all shells, including sh, csh,
 281      and scsh, read stdin unbuffered.  Applications that can tolerate
 282      buffered input on stdin can reset \ex{(current-input-port)} to
 283      block buffering for higher performance.  */
 284
 285   scm_cur_inp
 286     = scm_standard_stream_to_port (0,
 287                                    isatty (0) ? "r0" : "r",
 288                                    "standard input");
 289   scm_cur_outp = scm_standard_stream_to_port (1,
 290                                               isatty (1) ? "w0" : "w",
 291                                               "standard output");
 292   scm_cur_errp = scm_standard_stream_to_port (2,
 293                                               isatty (2) ? "w0" : "w",
 294                                               "standard error");
 295
 296   scm_cur_loadp = SCM_BOOL_F;
 297 }
 298
 299
 300 \f
 301 /* Loading the startup Scheme files.  */
 302
 303 /* The boot code "ice-9/boot-9" is only loaded by scm_boot_guile when
 304    this is false.  The unexec code uses this, to keep ice_9 from being
 305    loaded into dumped guile executables.  */
 306 int scm_ice_9_already_loaded = 0;
 307
 308 void
 309 scm_load_startup_files ()
 310 {
 311   /* We want a path only containing directories from GUILE_LOAD_PATH,
 312      SCM_SITE_DIR and SCM_LIBRARY_DIR when searching for the site init
 313      file, so we do this before loading Ice-9.  */
 314   SCM init_path = scm_sys_search_load_path (scm_makfrom0str ("init.scm"));
 315
 316   /* Load Ice-9.  */
 317   if (!scm_ice_9_already_loaded)
 318     {
 319       scm_primitive_load_path (scm_makfrom0str ("ice-9/boot-9.scm"));
 320
 321       /* Load the init.scm file.  */
 322       if (SCM_NFALSEP (init_path))
 323         scm_primitive_load (init_path);
 324     }
 325 }
 326
 327 \f
 328 /* The main init code.  */
 329
 330 #ifdef _UNICOS
 331 typedef int setjmp_type;
 332 #else
 333 typedef long setjmp_type;
 334 #endif
 335
 336 /* All the data needed to invoke the main function.  */
 337 struct main_func_closure
 338 {
 339   /* the function to call */
 340   void (*main_func)(void *closure, int argc, char **argv);
 341   void *closure;                /* dummy data to pass it */
 342   int argc;
 343   char **argv;                  /* the argument list it should receive */
 344 };
 345
 346
 347 static void scm_init_guile_1 (SCM_STACKITEM *base);
 348 static void scm_boot_guile_1 (SCM_STACKITEM *base,
 349                               struct main_func_closure *closure);
 350 static SCM invoke_main_func(void *body_data);
 351
 352
 353 /* Fire up the Guile Scheme interpreter.
 354
 355    Call MAIN_FUNC, passing it CLOSURE, ARGC, and ARGV.  MAIN_FUNC
 356    should do all the work of the program (initializing other packages,
 357    reading user input, etc.) before returning.  When MAIN_FUNC
 358    returns, call exit (0); this function never returns.  If you want
 359    some other exit value, MAIN_FUNC may call exit itself.
 360
 361    scm_boot_guile arranges for program-arguments to return the strings
 362    given by ARGC and ARGV.  If MAIN_FUNC modifies ARGC/ARGV, should
 363    call scm_set_program_arguments with the final list, so Scheme code
 364    will know which arguments have been processed.
 365
 366    scm_boot_guile establishes a catch-all catch handler which prints
 367    an error message and exits the process.  This means that Guile
 368    exits in a coherent way when system errors occur and the user isn't
 369    prepared to handle it.  If the user doesn't like this behavior,
 370    they can establish their own universal catcher to shadow this one.
 371
 372    Why must the caller do all the real work from MAIN_FUNC?  The
 373    garbage collector assumes that all local variables of type SCM will
 374    be above scm_boot_guile's stack frame on the stack.  If you try to
 375    manipulate SCM values after this function returns, it's the luck of
 376    the draw whether the GC will be able to find the objects you
 377    allocate.  So, scm_boot_guile function exits, rather than
 378    returning, to discourage people from making that mistake.  */
 379
 380
 381 void
 382 scm_boot_guile (int argc, char ** argv, void (*main_func) (), void *closure)
 383 {
 384   /* The garbage collector uses the address of this variable as one
 385      end of the stack, and the address of one of its own local
 386      variables as the other end.  */
 387   SCM_STACKITEM dummy;
 388   struct main_func_closure c;
 389
 390   c.main_func = main_func;
 391   c.closure = closure;
 392   c.argc = argc;
 393   c.argv = argv;
 394
 395   scm_boot_guile_1 (&dummy, &c);
 396 }
 397
 398 void
 399 scm_init_guile ()
 400 {
 401   scm_init_guile_1 ((SCM_STACKITEM *)scm_get_stack_base ());
 402 }
 403
 404 int scm_initialized_p = 0;
 405
 406 static void
 407 scm_init_guile_1 (SCM_STACKITEM *base)
 408 {
 409   if (scm_initialized_p)
 410     return;
 411
 412   if (base == NULL)
 413     {
 414       fprintf (stderr, "cannot determine stack base!\n");
 415       abort ();
 416     }
 417
 418   if (sizeof (mpz_t) > (3 * sizeof (scm_t_bits)))
 419     {
 420       fprintf (stderr,
 421                "GMP's mpz_t must fit into a double_cell,"
 422                "but doesn't seem to here.\n");
 423     }
 424
 425   scm_block_gc = 1;
 426
 427   scm_storage_prehistory ();
 428   scm_threads_prehistory ();
 429   scm_ports_prehistory ();
 430   scm_smob_prehistory ();
 431   scm_hashtab_prehistory ();    /* requires storage_prehistory */
 432   scm_tables_prehistory ();
 433 #ifdef GUILE_DEBUG_MALLOC
 434   scm_debug_malloc_prehistory ();
 435 #endif
 436   if (scm_init_storage ())        /* requires threads_prehistory,
 437                                      smob_prehistory and
 438                                      hashtab_prehistory */
 439     abort ();
 440
 441   scm_struct_prehistory ();       /* requires storage */
 442   scm_symbols_prehistory ();      /* requires storage */
 443   scm_weaks_prehistory ();        /* requires storage */
 444   scm_init_subr_table ();
 445   scm_environments_prehistory (); /* requires storage */
 446   scm_modules_prehistory ();      /* requires storage and hash tables */
 447   scm_init_variable ();           /* all bindings need variables */
 448   scm_init_continuations ();
 449   scm_init_root ();               /* requires continuations */
 450   scm_init_threads (base);
 451   start_stack (base);
 452   scm_init_gsubr ();
 453   scm_init_thread_procs ();       /* requires gsubrs */
 454   scm_init_procprop ();
 455   scm_init_environments ();
 456   scm_init_feature ();
 457   scm_init_alist ();
 458   scm_init_arbiters ();
 459   scm_init_async ();
 460   scm_init_boolean ();
 461   scm_init_chars ();
 462 #ifdef GUILE_DEBUG_MALLOC
 463   scm_init_debug_malloc ();
 464 #endif
 465   scm_init_dynwind ();
 466   scm_init_eq ();
 467   scm_init_error ();
 468   scm_init_fluids ();
 469   scm_init_futures ();
 470   scm_init_backtrace ();        /* Requires fluids */
 471   scm_init_fports ();
 472   scm_init_strports ();
 473   scm_init_gdbint ();           /* Requires strports */
 474   scm_init_hash ();
 475   scm_init_hashtab ();
 476   scm_init_deprecation ();      /* Requires hashtabs */
 477   scm_init_objprop ();
 478   scm_init_properties ();
 479   scm_init_hooks ();            /* Requires smob_prehistory */
 480   scm_init_gc ();               /* Requires hooks, async */
 481   scm_init_ioext ();
 482   scm_init_keywords ();
 483   scm_init_list ();
 484   scm_init_macros ();
 485   scm_init_mallocs ();
 486   scm_init_modules ();
 487   scm_init_numbers ();
 488   scm_init_options ();
 489   scm_init_pairs ();
 490   scm_init_ports ();
 491 #ifdef HAVE_POSIX
 492   scm_init_filesys ();
 493   scm_init_posix ();
 494 #endif
 495 #ifdef HAVE_REGCOMP
 496   scm_init_regex_posix ();
 497 #endif
 498   scm_init_procs ();
 499   scm_init_scmsigs ();
 500 #ifdef HAVE_NETWORKING
 501   scm_init_net_db ();
 502   scm_init_socket ();
 503 #endif
 504   scm_init_sort ();
 505 #ifdef DEBUG_EXTENSIONS
 506   scm_init_srcprop ();
 507 #endif
 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_strop ();
 521   scm_init_throw ();
 522   scm_init_vectors ();
 523   scm_init_version ();
 524   scm_init_weaks ();
 525   scm_init_guardians ();
 526   scm_init_vports ();
 527   scm_init_eval ();
 528   scm_init_evalext ();
 529 #ifdef DEBUG_EXTENSIONS
 530   scm_init_debug ();    /* Requires macro smobs */
 531 #endif
 532   scm_init_random ();
 533 #if SCM_HAVE_ARRAYS
 534   scm_init_ramap ();
 535   scm_init_unif ();
 536 #endif
 537   scm_init_simpos ();
 538   scm_init_load_path ();
 539   scm_init_standard_ports ();  /* Requires fports */
 540 #ifdef DYNAMIC_LINKING
 541   scm_init_dynamic_linking ();
 542 #endif
 543 #if SCM_ENABLE_ELISP
 544   scm_init_lang ();
 545 #endif /* SCM_ENABLE_ELISP */
 546   scm_init_script ();
 547
 548   scm_init_goops ();
 549
 550 #if SCM_ENABLE_DEPRECATED == 1
 551   scm_i_init_deprecated ();
 552 #endif
 553
 554   scm_initialized_p = 1;
 555
 556   scm_block_gc = 0;             /* permit the gc to run */
 557   /* ints still disabled */
 558
 559 #ifdef STACK_CHECKING
 560   scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 561 #endif
 562
 563   scm_init_rdelim ();
 564   scm_init_rw ();
 565   scm_init_extensions ();
 566
 567   scm_load_startup_files ();
 568 }
 569
 570 /* Record here whether SCM_BOOT_GUILE_1 has already been called.  This
 571    variable is now here and not inside SCM_BOOT_GUILE_1 so that one
 572    can tweak it. This is necessary for unexec to work. (Hey, "1-live"
 573    is the name of a local radiostation...) */
 574
 575 int scm_boot_guile_1_live = 0;
 576
 577 static void
 578 scm_boot_guile_1 (SCM_STACKITEM *base, struct main_func_closure *closure)
 579 {
 580   scm_init_guile_1 (base);
 581
 582   /* This function is not re-entrant. */
 583   if (scm_boot_guile_1_live)
 584     abort ();
 585
 586   scm_boot_guile_1_live = 1;
 587
 588   scm_set_program_arguments (closure->argc, closure->argv, 0);
 589   invoke_main_func (closure);
 590
 591   scm_restore_signals ();
 592
 593   /* This tick gives any pending
 594    * asyncs a chance to run.  This must be done after
 595    * the call to scm_restore_signals.
 596    */
 597   SCM_ASYNC_TICK;
 598
 599   /* If the caller doesn't want this, they should return from
 600      main_func themselves.  */
 601   exit (0);
 602 }
 603
 604 static SCM
 605 invoke_main_func (void *body_data)
 606 {
 607   struct main_func_closure *closure = (struct main_func_closure *) body_data;
 608
 609   (*closure->main_func) (closure->closure, closure->argc, closure->argv);
 610
 611   /* never reached */
 612   return SCM_UNDEFINED;
 613 }
 614
 615 /*
 616   Local Variables:
 617   c-file-style: "gnu"
 618   End:
 619 */