libguile/init.c

   1 /*      Copyright (C) 1995,1996 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, 675 Mass Ave, Cambridge, MA 02139, USA.
  16  *
  17  * As a special exception, the Free Software Foundation gives permission
  18  * for additional uses of the text contained in its release of GUILE.
  19  *
  20  * The exception is that, if you link the GUILE library with other files
  21  * to produce an executable, this does not by itself cause the
  22  * resulting executable to be covered by the GNU General Public License.
  23  * Your use of that executable is in no way restricted on account of
  24  * linking the GUILE library code into it.
  25  *
  26  * This exception does not however invalidate any other reasons why
  27  * the executable file might be covered by the GNU General Public License.
  28  *
  29  * This exception applies only to the code released by the
  30  * Free Software Foundation under the name GUILE.  If you copy
  31  * code from other Free Software Foundation releases into a copy of
  32  * GUILE, as the General Public License permits, the exception does
  33  * not apply to the code that you add in this way.  To avoid misleading
  34  * anyone as to the status of such modified files, you must delete
  35  * this exception notice from them.
  36  *
  37  * If you write modifications of your own for GUILE, it is your choice
  38  * whether to permit this exception to apply to your modifications.
  39  * If you do not wish that, delete this exception notice.
  40  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45
  46 /* Everybody has an init function.  */
  47 #include "alist.h"
  48 #include "append.h"
  49 #include "arbiters.h"
  50 #include "async.h"
  51 #include "boolean.h"
  52 #include "chars.h"
  53 #include "continuations.h"
  54 #ifdef DEBUG_EXTENSIONS
  55 #include "debug.h"
  56 #endif
  57 #include "dynwind.h"
  58 #include "eq.h"
  59 #include "error.h"
  60 #include "eval.h"
  61 #include "fdsocket.h"
  62 #include "feature.h"
  63 #include "filesys.h"
  64 #include "fports.h"
  65 #include "gc.h"
  66 #include "gdbint.h"
  67 #include "gsubr.h"
  68 #include "hash.h"
  69 #include "hashtab.h"
  70 #include "ioext.h"
  71 #include "kw.h"
  72 #include "list.h"
  73 #include "load.h"
  74 #include "mallocs.h"
  75 #include "mbstrings.h"
  76 #include "numbers.h"
  77 #include "objprop.h"
  78 #include "options.h"
  79 #include "pairs.h"
  80 #include "ports.h"
  81 #include "posix.h"
  82 #include "print.h"
  83 #include "procprop.h"
  84 #include "procs.h"
  85 #include "ramap.h"
  86 #include "read.h"
  87 #include "scmsigs.h"
  88 #include "sequences.h"
  89 #include "simpos.h"
  90 #include "smob.h"
  91 #include "socket.h"
  92 #include "srcprop.h"
  93 #include "stackchk.h"
  94 #include "stime.h"
  95 #include "strings.h"
  96 #include "strop.h"
  97 #include "strorder.h"
  98 #include "strports.h"
  99 #include "struct.h"
 100 #include "symbols.h"
 101 #include "tag.h"
 102 #include "throw.h"
 103 #include "unif.h"
 104 #include "variable.h"
 105 #include "vectors.h"
 106 #include "version.h"
 107 #include "vports.h"
 108 #include "weaks.h"
 109
 110 #include "init.h"
 111
 112 #ifdef HAVE_STRING_H
 113 #include <string.h>
 114 #endif
 115 #ifdef HAVE_UNISTD_H
 116 #include <unistd.h>
 117 #endif
 118 \f
 119
 120 void
 121 scm_start_stack (base, in, out, err)
 122      void * base;
 123      FILE * in;
 124      FILE * out;
 125      FILE * err;
 126 {
 127   SCM root;
 128   struct scm_port_table * pt;
 129
 130   root = scm_permanent_object (scm_make_root (SCM_UNDEFINED));
 131   scm_set_root (SCM_ROOT_STATE (root));
 132
 133   scm_stack_base = base;
 134
 135   /* Create standard ports from stdio files, if requested to do so.
 136    */
 137
 138   if (!in)
 139     {
 140       scm_def_inp = SCM_BOOL_F;
 141     }
 142   else
 143     {
 144       SCM_NEWCELL (scm_def_inp);
 145       pt = scm_add_to_port_table (scm_def_inp);
 146       SCM_CAR (scm_def_inp) = (scm_tc16_fport | SCM_OPN | SCM_RDNG);
 147       SCM_SETPTAB_ENTRY (scm_def_inp, pt);
 148       SCM_SETSTREAM (scm_def_inp, (SCM)in);
 149       if (isatty (fileno (in)))
 150         {
 151           scm_setbuf0 (scm_def_inp); /* turn off stdin buffering */
 152           SCM_CAR (scm_def_inp) |= SCM_BUF0;
 153         }
 154       scm_set_port_revealed_x (scm_def_inp, SCM_MAKINUM (1));
 155     }
 156
 157   if (!out)
 158     {
 159       scm_def_outp = SCM_BOOL_F;
 160     }
 161   else
 162     {
 163       SCM_NEWCELL (scm_def_outp);
 164       pt = scm_add_to_port_table (scm_def_outp);
 165       SCM_CAR (scm_def_outp) = (scm_tc16_fport | SCM_OPN | SCM_WRTNG);
 166       SCM_SETPTAB_ENTRY (scm_def_outp, pt);
 167       SCM_SETSTREAM (scm_def_outp, (SCM)out);
 168       scm_set_port_revealed_x (scm_def_outp, SCM_MAKINUM (1));
 169     }
 170
 171   if (!err)
 172     {
 173       scm_def_errp = SCM_BOOL_F;
 174     }
 175   else
 176     {
 177       SCM_NEWCELL (scm_def_errp);
 178       pt = scm_add_to_port_table (scm_def_errp);
 179       SCM_CAR (scm_def_errp) = (scm_tc16_fport | SCM_OPN | SCM_WRTNG);
 180       SCM_SETPTAB_ENTRY (scm_def_errp, pt);
 181       SCM_SETSTREAM (scm_def_errp, (SCM)err);
 182       scm_set_port_revealed_x (scm_def_errp, SCM_MAKINUM (1));
 183     }
 184
 185   scm_cur_inp = scm_def_inp;
 186   scm_cur_outp = scm_def_outp;
 187   scm_cur_errp = scm_def_errp;
 188
 189
 190   scm_progargs = SCM_BOOL_F;    /* vestigial */
 191   scm_exitval = SCM_BOOL_F;     /* vestigial */
 192
 193   scm_top_level_lookup_thunk_var = SCM_BOOL_F;
 194   scm_system_transformer = SCM_BOOL_F;
 195
 196   /* Create an object to hold the root continuation.
 197    */
 198   SCM_NEWCELL (scm_rootcont);
 199   SCM_SETJMPBUF (scm_rootcont, scm_must_malloc ((long) sizeof (regs), "continuation"));
 200   SCM_CAR (scm_rootcont) = scm_tc7_contin;
 201   /* The root continuation if further initialized by scm_restart_stack. */
 202
 203   /* Create the look-aside stack for variables that are shared between
 204    * captured continuations.
 205    */
 206   scm_continuation_stack = scm_make_vector (SCM_MAKINUM (512), SCM_UNDEFINED, SCM_UNDEFINED);
 207   /* The continuation stack is further initialized by scm_restart_stack. */
 208
 209   /* The remainder of stack initialization is factored out to another function so that
 210    * if this stack is ever exitted, it can be re-entered using scm_restart_stack.
 211    */
 212   scm_restart_stack (base);
 213 }
 214
 215
 216 void
 217 scm_restart_stack (base)
 218      void * base;
 219 {
 220   scm_dynwinds = SCM_EOL;
 221   SCM_DYNENV (scm_rootcont) = SCM_EOL;
 222   SCM_THROW_VALUE (scm_rootcont) = SCM_EOL;
 223 #ifdef DEBUG_EXTENSIONS
 224   SCM_DFRAME (scm_rootcont) = last_debug_info_frame = 0;
 225 #endif
 226   SCM_BASE (scm_rootcont) = base;
 227   scm_continuation_stack_ptr = SCM_MAKINUM (0);
 228 }
 229
 230 #if 0
 231 static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
 232
 233 #ifdef __STDC__
 234 static void
 235 fixconfig (char *s1, char *s2, int s)
 236 #else
 237 static void
 238 fixconfig (s1, s2, s)
 239      char *s1;
 240      char *s2;
 241      int s;
 242 #endif
 243 {
 244   fputs (s1, stderr);
 245   fputs (s2, stderr);
 246   fputs ("\nin ", stderr);
 247   fputs (s ? "setjump" : "scmfig", stderr);
 248   fputs (".h and recompile scm\n", stderr);
 249   exit (1);
 250 }
 251
 252
 253
 254 static void
 255 check_config ()
 256 {
 257   scm_sizet j;
 258
 259   j = HEAP_SEG_SIZE;
 260   if (HEAP_SEG_SIZE != j)
 261     fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);
 262
 263 #ifdef SCM_SINGLES
 264   if (sizeof (float) != sizeof (long))
 265       fixconfig (remsg, "SCM_SINGLES", 0);
 266 #endif /* def SCM_SINGLES */
 267
 268
 269 #ifdef SCM_BIGDIG
 270   if (2 * SCM_BITSPERDIG / SCM_CHAR_BIT > sizeof (long))
 271       fixconfig (remsg, "SCM_BIGDIG", 0);
 272 #ifndef SCM_DIGSTOOBIG
 273   if (SCM_DIGSPERLONG * sizeof (SCM_BIGDIG) > sizeof (long))
 274       fixconfig (addmsg, "SCM_DIGSTOOBIG", 0);
 275 #endif
 276 #endif
 277
 278 #ifdef SCM_STACK_GROWS_UP
 279   if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0)
 280     fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
 281 #else
 282   if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0)
 283     fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1);
 284 #endif
 285 }
 286 #endif
 287
 288
 289 \f
 290 #ifdef _UNICOS
 291 typedef int setjmp_type;
 292 #else
 293 typedef long setjmp_type;
 294 #endif
 295
 296 /* Fire up Scheme.
 297  *
 298  * argc and argv are made the return values of program-arguments.
 299  *
 300  * in, out, and err, if not NULL, become the standard ports.
 301  *      If NULL is passed, your "initfunc" should set up the
 302  *      standard ports.
 303  *
 304  * boot_cmd is a string containing a Scheme expression to evaluate
 305  *      to get things rolling.
 306  *
 307  * result is returned a string containing a printed result of evaluating
 308  *      the boot command.
 309  *
 310  * the return value is:
 311  *      scm_boot_ok       - evaluation concluded normally
 312  *      scm_boot_error    - evaluation concluded with a Scheme error
 313  *      scm_boot_emem     - allocation error mallocing *result
 314  *      scm_boot_ereenter - scm_boot_guile was called re-entrantly, which is
 315  *                          prohibited.
 316  */
 317
 318 int
 319 scm_boot_guile (result, argc, argv, in, out, err, init_func, boot_cmd)
 320      char ** result;
 321      int argc;
 322      char ** argv;
 323      FILE * in;
 324      FILE * out;
 325      FILE * err;
 326      void (*init_func) ();
 327      char * boot_cmd;
 328 {
 329   static int initialized = 0;
 330   static int live = 0;
 331   SCM_STACKITEM i;
 332   setjmp_type setjmp_val;
 333   int stat;
 334
 335   if (live)                     /* This function is not re-entrant. */
 336     {
 337       return scm_boot_ereenter;
 338     }
 339
 340   live = 1;
 341
 342   scm_ints_disabled = 1;
 343   scm_block_gc = 1;
 344
 345   if (initialized)
 346     {
 347       scm_restart_stack (&i);
 348     }
 349   else
 350     {
 351       scm_ports_prehistory ();
 352       scm_smob_prehistory ();
 353       scm_tables_prehistory ();
 354       scm_init_storage (0);
 355       scm_init_root ();
 356 #ifdef USE_THREADS
 357       scm_init_threads ();
 358 #endif
 359       scm_start_stack (&i, in, out, err);
 360       scm_init_gsubr ();
 361       scm_init_feature ();
 362       scm_init_alist ();
 363       scm_init_append ();
 364       scm_init_arbiters ();
 365       scm_init_async ();
 366       scm_init_boolean ();
 367       scm_init_chars ();
 368       scm_init_continuations ();
 369 #ifdef DEBUG_EXTENSIONS
 370       scm_init_debug ();
 371 #endif
 372       scm_init_dynwind ();
 373       scm_init_eq ();
 374       scm_init_error ();
 375       scm_init_fdsocket ();
 376       scm_init_fports ();
 377       scm_init_filesys ();
 378       scm_init_gc ();
 379       scm_init_gdbint ();
 380       scm_init_hash ();
 381       scm_init_hashtab ();
 382       scm_init_ioext ();
 383       scm_init_kw ();
 384       scm_init_list ();
 385       scm_init_mallocs ();
 386       scm_init_numbers ();
 387       scm_init_objprop ();
 388 #if DEBUG_EXTENSIONS
 389       /* Excluding this until it's really needed makes the binary
 390        * smaller after linking.  */
 391       scm_init_options ();
 392 #endif
 393       scm_init_pairs ();
 394       scm_init_ports ();
 395       scm_init_posix ();
 396       scm_init_procs ();
 397       scm_init_procprop ();
 398       scm_init_scmsigs ();
 399       scm_init_socket ();
 400 #ifdef DEBUG_EXTENSIONS
 401       scm_init_srcprop ();
 402 #endif
 403       scm_init_stackchk ();
 404       scm_init_strports ();
 405       scm_init_symbols ();
 406       scm_init_tag ();
 407       scm_init_load ();
 408       scm_init_struct ();
 409       scm_init_print ();        /* Requires struct */
 410       scm_init_read ();
 411       scm_init_sequences ();
 412       scm_init_stime ();
 413       scm_init_strings ();
 414       scm_init_strorder ();
 415       scm_init_mbstrings ();
 416       scm_init_strop ();
 417       scm_init_throw ();
 418       scm_init_variable ();
 419       scm_init_vectors ();
 420       scm_init_version ();
 421       scm_init_weaks ();
 422       scm_init_vports ();
 423       scm_init_eval ();
 424       scm_init_ramap ();
 425       scm_init_unif ();
 426       scm_init_simpos ();
 427       scm_progargs = scm_makfromstrs (argc, argv);
 428       scm_init_load_path ();
 429       initialized = 1;
 430     }
 431
 432   scm_block_gc = 0;             /* permit the gc to run */
 433   /* ints still disabled */
 434
 435   {
 436     SCM command;
 437
 438     command = scm_makfrom0str (boot_cmd);
 439
 440     setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont));
 441
 442 #ifdef STACK_CHECKING
 443     scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 444 #endif
 445     if (!setjmp_val)
 446       {
 447         SCM last = SCM_UNDEFINED;
 448         scm_init_signals ();
 449
 450         /* Call the initialization function passed in by the user, if
 451            present.  */
 452         if (init_func) (*init_func) ();
 453
 454         /* Evaluate boot_cmd string.  */
 455         {
 456           SCM p;
 457           SCM form;
 458
 459           p = scm_mkstrport (SCM_MAKINUM (0),
 460                              command,
 461                              SCM_OPN | SCM_RDNG,
 462                              "boot_guile");
 463           while (1)
 464             {
 465               form = scm_read (p, SCM_BOOL_F, SCM_BOOL_F);
 466               if (SCM_EOF_VAL == form)
 467                 break;
 468               last = scm_eval_x (form);
 469             }
 470
 471         }
 472
 473         scm_restore_signals ();
 474         /* This tick gives any pending
 475          * asyncs a chance to run.  This must be done after
 476          * the call to scm_restore_signals.
 477          */
 478         SCM_ASYNC_TICK;
 479
 480         scm_ints_disabled = 1;  /* Hopefully redundant but just to be sure. */
 481
 482         {
 483           SCM str_answer;
 484
 485           str_answer = scm_strprint_obj (last);
 486           *result = (char *)malloc (1 + SCM_LENGTH (str_answer));
 487           if (!*result)
 488             stat = scm_boot_emem;
 489           else
 490             {
 491               memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer));
 492               (*result)[SCM_LENGTH (str_answer)] = 0;
 493               stat = scm_boot_ok;
 494             }
 495         }
 496       }
 497     else
 498       {
 499         /* This is reached if an unhandled throw terminated Scheme.
 500          * Such an occurence should be extremely unlikely -- it indicates
 501          * a programming error in the boot code.
 502          *
 503          * Details of the bogus exception are stored in scm_exitval even
 504          * though that isn't currently reflected in the return value.
 505          * !!!
 506          */
 507
 508         scm_restore_signals ();
 509         /* This tick gives any pending
 510          * asyncs a chance to run.  This must be done after
 511          * the call to scm_restore_signals.
 512          *
 513          * Note that an unhandled exception during signal handling
 514          * will put as back at the call to scm_restore_signals immediately
 515          * preceeding.   A sufficiently bogus signal handler could
 516          * conceivably cause an infinite loop here.
 517          */
 518         SCM_ASYNC_TICK;
 519
 520         scm_ints_disabled = 1;  /* Hopefully redundant but just to be sure. */
 521
 522         {
 523           SCM str_answer;
 524
 525           str_answer = scm_strprint_obj (scm_exitval);
 526           *result = (char *)malloc (1 + SCM_LENGTH (str_answer));
 527           if (!*result)
 528             stat = scm_boot_emem;
 529           else
 530             {
 531               memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer));
 532               (*result)[SCM_LENGTH (str_answer)] = 0;
 533               stat = scm_boot_error;
 534             }
 535         }
 536       }
 537   }
 538
 539   scm_block_gc = 1;
 540   live = 0;
 541   return stat;
 542 }