libguile/init.c

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