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