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   SCM_SEQ (scm_rootcont) = 0;
 202   /* The root continuation if further initialized by scm_restart_stack. */
 203
 204   /* Create the look-aside stack for variables that are shared between
 205    * captured continuations.
 206    */
 207   scm_continuation_stack = scm_make_vector (SCM_MAKINUM (512), SCM_UNDEFINED, SCM_UNDEFINED);
 208   /* The continuation stack is further initialized by scm_restart_stack. */
 209
 210   /* The remainder of stack initialization is factored out to another function so that
 211    * if this stack is ever exitted, it can be re-entered using scm_restart_stack.
 212    */
 213   scm_restart_stack (base);
 214 }
 215
 216
 217 void
 218 scm_restart_stack (base)
 219      void * base;
 220 {
 221   scm_dynwinds = SCM_EOL;
 222   SCM_DYNENV (scm_rootcont) = SCM_EOL;
 223   SCM_THROW_VALUE (scm_rootcont) = SCM_EOL;
 224 #ifdef DEBUG_EXTENSIONS
 225   SCM_DFRAME (scm_rootcont) = scm_last_debug_frame = 0;
 226 #endif
 227   SCM_BASE (scm_rootcont) = base;
 228   scm_continuation_stack_ptr = SCM_MAKINUM (0);
 229 }
 230
 231 #if 0
 232 static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
 233
 234 #ifdef __STDC__
 235 static void
 236 fixconfig (char *s1, char *s2, int s)
 237 #else
 238 static void
 239 fixconfig (s1, s2, s)
 240      char *s1;
 241      char *s2;
 242      int s;
 243 #endif
 244 {
 245   fputs (s1, stderr);
 246   fputs (s2, stderr);
 247   fputs ("\nin ", stderr);
 248   fputs (s ? "setjump" : "scmfig", stderr);
 249   fputs (".h and recompile scm\n", stderr);
 250   exit (1);
 251 }
 252
 253
 254
 255 static void
 256 check_config ()
 257 {
 258   scm_sizet j;
 259
 260   j = HEAP_SEG_SIZE;
 261   if (HEAP_SEG_SIZE != j)
 262     fixconfig ("reduce", "size of HEAP_SEG_SIZE", 0);
 263
 264 #ifdef SCM_SINGLES
 265   if (sizeof (float) != sizeof (long))
 266       fixconfig (remsg, "SCM_SINGLES", 0);
 267 #endif /* def SCM_SINGLES */
 268
 269
 270 #ifdef SCM_BIGDIG
 271   if (2 * SCM_BITSPERDIG / SCM_CHAR_BIT > sizeof (long))
 272       fixconfig (remsg, "SCM_BIGDIG", 0);
 273 #ifndef SCM_DIGSTOOBIG
 274   if (SCM_DIGSPERLONG * sizeof (SCM_BIGDIG) > sizeof (long))
 275       fixconfig (addmsg, "SCM_DIGSTOOBIG", 0);
 276 #endif
 277 #endif
 278
 279 #ifdef SCM_STACK_GROWS_UP
 280   if (((SCM_STACKITEM *) & j - stack_start_ptr) < 0)
 281     fixconfig (remsg, "SCM_STACK_GROWS_UP", 1);
 282 #else
 283   if ((stack_start_ptr - (SCM_STACKITEM *) & j) < 0)
 284     fixconfig (addmsg, "SCM_STACK_GROWS_UP", 1);
 285 #endif
 286 }
 287 #endif
 288
 289
 290 \f
 291 #ifdef _UNICOS
 292 typedef int setjmp_type;
 293 #else
 294 typedef long setjmp_type;
 295 #endif
 296
 297 /* Fire up Scheme.
 298  *
 299  * argc and argv are made the return values of program-arguments.
 300  *
 301  * in, out, and err, if not NULL, become the standard ports.
 302  *      If NULL is passed, your "initfunc" should set up the
 303  *      standard ports.
 304  *
 305  * boot_cmd is a string containing a Scheme expression to evaluate
 306  *      to get things rolling.
 307  *
 308  * result is returned a string containing a printed result of evaluating
 309  *      the boot command.
 310  *
 311  * the return value is:
 312  *      scm_boot_ok       - evaluation concluded normally
 313  *      scm_boot_error    - evaluation concluded with a Scheme error
 314  *      scm_boot_emem     - allocation error mallocing *result
 315  *      scm_boot_ereenter - scm_boot_guile was called re-entrantly, which is
 316  *                          prohibited.
 317  */
 318
 319 int
 320 scm_boot_guile (result, argc, argv, in, out, err, init_func, boot_cmd)
 321      char ** result;
 322      int argc;
 323      char ** argv;
 324      FILE * in;
 325      FILE * out;
 326      FILE * err;
 327      void (*init_func) ();
 328      char * boot_cmd;
 329 {
 330   static int initialized = 0;
 331   static int live = 0;
 332   SCM_STACKITEM i;
 333   setjmp_type setjmp_val;
 334   int stat;
 335
 336   if (live)                     /* This function is not re-entrant. */
 337     {
 338       return scm_boot_ereenter;
 339     }
 340
 341   live = 1;
 342
 343   scm_ints_disabled = 1;
 344   scm_block_gc = 1;
 345
 346   if (initialized)
 347     {
 348       scm_restart_stack (&i);
 349     }
 350   else
 351     {
 352       scm_ports_prehistory ();
 353       scm_smob_prehistory ();
 354       scm_tables_prehistory ();
 355       scm_init_storage (0);
 356       scm_init_root ();
 357 #ifdef USE_THREADS
 358       scm_init_threads (&i);
 359 #endif
 360       scm_start_stack (&i, in, out, err);
 361       scm_init_gsubr ();
 362       scm_init_feature ();
 363       scm_init_alist ();
 364       scm_init_append ();
 365       scm_init_arbiters ();
 366       scm_init_async ();
 367       scm_init_boolean ();
 368       scm_init_chars ();
 369       scm_init_continuations ();
 370 #ifdef DEBUG_EXTENSIONS
 371       scm_init_debug ();
 372 #endif
 373       scm_init_dynwind ();
 374       scm_init_eq ();
 375       scm_init_error ();
 376       scm_init_fdsocket ();
 377       scm_init_fports ();
 378       scm_init_filesys ();
 379       scm_init_gc ();
 380       scm_init_gdbint ();
 381       scm_init_hash ();
 382       scm_init_hashtab ();
 383       scm_init_ioext ();
 384       scm_init_kw ();
 385       scm_init_list ();
 386       scm_init_mallocs ();
 387       scm_init_numbers ();
 388       scm_init_objprop ();
 389 #if DEBUG_EXTENSIONS
 390       /* Excluding this until it's really needed makes the binary
 391        * smaller after linking.  */
 392       scm_init_options ();
 393 #endif
 394       scm_init_pairs ();
 395       scm_init_ports ();
 396       scm_init_posix ();
 397       scm_init_procs ();
 398       scm_init_procprop ();
 399       scm_init_scmsigs ();
 400       scm_init_socket ();
 401 #ifdef DEBUG_EXTENSIONS
 402       scm_init_srcprop ();
 403 #endif
 404       scm_init_stackchk ();
 405       scm_init_strports ();
 406       scm_init_symbols ();
 407       scm_init_tag ();
 408       scm_init_load ();
 409       scm_init_struct ();
 410       scm_init_print ();        /* Requires struct */
 411       scm_init_read ();
 412       scm_init_sequences ();
 413       scm_init_stime ();
 414       scm_init_strings ();
 415       scm_init_strorder ();
 416       scm_init_mbstrings ();
 417       scm_init_strop ();
 418       scm_init_throw ();
 419       scm_init_variable ();
 420       scm_init_vectors ();
 421       scm_init_version ();
 422       scm_init_weaks ();
 423       scm_init_vports ();
 424       scm_init_eval ();
 425       scm_init_ramap ();
 426       scm_init_unif ();
 427       scm_init_simpos ();
 428       scm_progargs = scm_makfromstrs (argc, argv);
 429       scm_init_load_path ();
 430       initialized = 1;
 431     }
 432
 433   scm_block_gc = 0;             /* permit the gc to run */
 434   /* ints still disabled */
 435
 436   {
 437     SCM command;
 438
 439     command = scm_makfrom0str (boot_cmd);
 440
 441     setjmp_val = setjmp (SCM_JMPBUF (scm_rootcont));
 442
 443 #ifdef STACK_CHECKING
 444     scm_stack_checking_enabled_p = SCM_STACK_CHECKING_P;
 445 #endif
 446     if (!setjmp_val)
 447       {
 448         SCM last = SCM_UNDEFINED;
 449         scm_init_signals ();
 450
 451         /* Call the initialization function passed in by the user, if
 452            present.  */
 453         if (init_func) (*init_func) ();
 454
 455         /* Evaluate boot_cmd string.  */
 456         {
 457           SCM p;
 458           SCM form;
 459
 460           p = scm_mkstrport (SCM_MAKINUM (0),
 461                              command,
 462                              SCM_OPN | SCM_RDNG,
 463                              "boot_guile");
 464           while (1)
 465             {
 466               form = scm_read (p, SCM_BOOL_F, SCM_BOOL_F);
 467               if (SCM_EOF_VAL == form)
 468                 break;
 469               last = scm_eval_x (form);
 470             }
 471
 472         }
 473
 474         scm_restore_signals ();
 475         /* This tick gives any pending
 476          * asyncs a chance to run.  This must be done after
 477          * the call to scm_restore_signals.
 478          */
 479         SCM_ASYNC_TICK;
 480
 481         scm_ints_disabled = 1;  /* Hopefully redundant but just to be sure. */
 482
 483         {
 484           SCM str_answer;
 485
 486           str_answer = scm_strprint_obj (last);
 487           *result = (char *)malloc (1 + SCM_LENGTH (str_answer));
 488           if (!*result)
 489             stat = scm_boot_emem;
 490           else
 491             {
 492               memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer));
 493               (*result)[SCM_LENGTH (str_answer)] = 0;
 494               stat = scm_boot_ok;
 495             }
 496         }
 497       }
 498     else
 499       {
 500         /* This is reached if an unhandled throw terminated Scheme.
 501          * Such an occurence should be extremely unlikely -- it indicates
 502          * a programming error in the boot code.
 503          *
 504          * Details of the bogus exception are stored in scm_exitval even
 505          * though that isn't currently reflected in the return value.
 506          * !!!
 507          */
 508
 509         scm_restore_signals ();
 510         /* This tick gives any pending
 511          * asyncs a chance to run.  This must be done after
 512          * the call to scm_restore_signals.
 513          *
 514          * Note that an unhandled exception during signal handling
 515          * will put as back at the call to scm_restore_signals immediately
 516          * preceeding.   A sufficiently bogus signal handler could
 517          * conceivably cause an infinite loop here.
 518          */
 519         SCM_ASYNC_TICK;
 520
 521         scm_ints_disabled = 1;  /* Hopefully redundant but just to be sure. */
 522
 523         {
 524           SCM str_answer;
 525
 526           str_answer = scm_strprint_obj (scm_exitval);
 527           *result = (char *)malloc (1 + SCM_LENGTH (str_answer));
 528           if (!*result)
 529             stat = scm_boot_emem;
 530           else
 531             {
 532               memcpy (*result, SCM_CHARS (str_answer), SCM_LENGTH (str_answer));
 533               (*result)[SCM_LENGTH (str_answer)] = 0;
 534               stat = scm_boot_error;
 535             }
 536         }
 537       }
 538   }
 539
 540   scm_block_gc = 1;
 541   live = 0;
 542   return stat;
 543 }