path: root/scm.c

/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc.
 * 
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 * 
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 * 
 * You should have received a copy of the GNU General Public License
 * along with this software; see the file COPYING.  If not, write to
 * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 * As a special exception, the Free Software Foundation gives permission
 * for additional uses of the text contained in its release of GUILE.
 *
 * The exception is that, if you link the GUILE library with other files
 * to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the GUILE library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the
 * Free Software Foundation under the name GUILE.  If you copy
 * code from other Free Software Foundation releases into a copy of
 * GUILE, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for GUILE, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.  
 */

/* "scm.c" top level and interrupt code.
   Author: Aubrey Jaffer */

#include <signal.h>
#include "scm.h"
#include "patchlvl.h"

#ifdef __IBMC__
# include <io.h>
#endif

#ifndef STDC_HEADERS
	int alarm P((unsigned int));
	int pause P((void));
	unsigned int sleep P((unsigned int seconds));
	char *getenv P((const char *name));
	int system P((const char *));
#else /* added by Denys Duchier */
# ifdef SVR4
#  include <unistd.h>
# endif
#endif

void	final_repl P((void));
void	init_dynl P((void));
void	init_edline P((void));
void	init_eval P((void));
void	init_features P((void));
void	init_gsubr P((void));
void	init_io P((void));
void	init_ioext P((void));
void	init_posix P((void));
void	init_ramap P((void));
void	init_record P((void));
void	init_rgx P((void));
void	init_rope P((void));
void	init_repl P((int iverbose));
void	init_sc2 P((void));
void	init_scl P((void));
void	init_signals P((void));
void	init_socket P((void));
void	init_subrs P((void));
void	init_tables P((void));
void	init_time P((void));
void	init_types P((void));
void	init_unif P((void));
void	reset_time P((void));

void init_banner()
{
  fputs("SCM version ", stderr);
  fputs(SCMVERSION, stderr);
  fputs(", Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 \
Free Software Foundation.\n\
SCM comes with ABSOLUTELY NO WARRANTY; for details type `(terms)'.\n\
This is free software, and you are welcome to redistribute it\n\
under certain conditions; type `(terms)' for details.\n", stderr);
}

SCM scm_init_extensions()
{
#ifdef COMPILED_INITS
    COMPILED_INITS;		/* initialize statically linked add-ons */
#endif
    return UNSPECIFIED;
}

#if (__TURBOC__==1)
# define signal ssignal		/* Needed for TURBOC V1.0 */
#endif

/* SIGRETTYPE is the type that signal handlers return.  See <signal.h>*/

#ifdef RETSIGTYPE
# define SIGRETTYPE RETSIGTYPE
#else
# ifdef STDC_HEADERS
#  if (__TURBOC__==1)
#   define SIGRETTYPE int
#  else
#   define SIGRETTYPE void
#  endif
# else
#  ifdef linux
#   define SIGRETTYPE void
#  else
#   define SIGRETTYPE int
#  endif
# endif
#endif

#ifdef vms
# ifdef __GNUC__
#  define SIGRETTYPE int
# endif
#endif

#define SIGNAL_BASE HUP_SIGNAL
#define NUM_SIGNALS (sizeof(sigdesc)/sizeof(sigdesc[0]))
/* PROF_SIGNAL appears below because it is the last signal
   defined in scm.h and in errmsgs in repl.c  */
static struct {
  int signo; SIGRETTYPE (*osig)(); SIGRETTYPE (*nsig)(); 
} sigdesc[PROF_SIGNAL - SIGNAL_BASE + 1];
void process_signals()
{
  int i = NUM_SIGNALS;
  unsigned long mask = (1L << (i-1));
  if (output_deferred) {
    output_deferred = 0;
    lflush(sys_errp);
  }
  if (SIG_deferred)
    while (i--) {
      if (SIG_deferred & mask) {
	SIG_deferred &= ~mask;
	handle_it(i + SIGNAL_BASE);
      }      
      mask >>= 1;
    }
  deferred_proc = 0;
}
static char s_unksig[] = "unknown signal";
static SIGRETTYPE err_signal(sig)
     int sig;
{
  int i = NUM_SIGNALS;
  signal(sig, err_signal);
  while (i--)
    if (sig == sigdesc[i].signo) break;
  wta(MAKINUM(sig), (i < 0 ? s_unksig : (char *)(i + SIGNAL_BASE)), "");
}
static SIGRETTYPE scmable_signal(sig)
     int sig;
{
  int oerr = errno;
  int i = NUM_SIGNALS;
  while (i--)
    if (sig == sigdesc[i].signo) break;
  ASSERT(i >= 0, MAKINUM(sig), s_unksig, "");
  signal(sig, scmable_signal);
  if (ints_disabled) {
    deferred_proc = process_signals;
    SIG_deferred |= (1L << i);
  }
  else {
#ifdef SIG_UNBLOCK
    sigset_t set;
    sigemptyset(&set);
    sigaddset(&set, sig);
    sigprocmask(SIG_UNBLOCK, &set, 0);
#endif
    SIG_deferred &= ~(1L << i);
    i += SIGNAL_BASE;
    if (i != handle_it(i)) {
      errno = oerr;
      wta(UNDEFINED, (char *)i, "");
    }
  }
  errno = oerr;
}

/* If doesn't have SIGFPE, disable FLOATS for the rest of this file. */

#ifndef SIGFPE
# undef FLOATS
#endif

#ifdef macintosh
# undef SIGALRM
#endif
#ifdef atarist
# undef SIGALRM			/* only available via MiNT libs */
#endif
#ifdef GO32
# undef SIGALRM
#endif
#ifdef __HIGHC__
# undef SIGALRM
#endif
#ifdef SIGALRM
static char s_alarm[] = "alarm";
SCM lalarm(i)
     SCM i;
{
  unsigned int j;
  ASSERT(INUMP(i) && (INUM(i) >= 0), i, ARG1, s_alarm);
  SYSCALL(j = alarm(INUM(i)););
  return MAKINUM(j);
}
# ifdef SIGPROF
#  include <sys/time.h>
static char s_proftimer[] = "profile-timer";
SCM scm_proftimer(interval)
     SCM interval;
{
  struct itimerval tval, oval;
  int w;
  if (UNBNDP(interval))
    SYSCALL(w = getitimer(ITIMER_PROF, &oval););
  else {
    if (BOOL_F==interval) interval = INUM0;
    ASSERT(INUMP(interval), interval, ARG2, s_proftimer);
    tval.it_interval.tv_sec = INUM(interval) / 1000;
    tval.it_interval.tv_usec = (INUM(interval) % 1000)*1000;
    tval.it_value.tv_sec = tval.it_interval.tv_sec;
    tval.it_value.tv_usec = tval.it_interval.tv_usec;
    SYSCALL(w = setitimer(ITIMER_PROF, &tval, &oval););
  }
  if (w) return BOOL_F;
  return MAKINUM(oval.it_interval.tv_usec/1000 + 
		 oval.it_interval.tv_sec*1000);
}
# endif
# ifndef AMIGA
#  ifndef __CYGWIN32__
SCM l_pause()
{
  pause();
  return UNSPECIFIED;
}
#  endif
# endif
#endif /* SIGALRM */

#ifdef _WIN32
# include <windows.h>
#endif
#ifndef AMIGA
# ifndef _Windows
static char s_sleep[] = "sleep";
SCM l_sleep(i)
     SCM i;
{
  unsigned int j = 0;
  ASSERT(INUMP(i) && (INUM(i) >= 0), i, ARG1, s_sleep);
#  ifdef __HIGHC__
  SYSCALL(sleep(INUM(i)););
#  else
#   ifdef _WIN32
  Sleep(INUM(i));
#   else
  SYSCALL(j = sleep(INUM(i)););
#   endif
#  endif
  return MAKINUM(j);
}
# endif
#endif

#ifndef _WIN32
# ifndef GO32
#  ifndef sun
#   ifndef THINK_C
/* int raise P((int sig)); */
static char s_raise[] = "raise";
SCM l_raise(sig)
     SCM sig;
{
  ASSERT(INUMP(sig), sig, ARG1, s_raise);
#    ifdef vms
  return MAKINUM(gsignal((int)INUM(sig)));
#    else
#     ifndef __TURBOC__
#      ifdef STDC_HEADERS
#       ifndef __MWERKS__
  return kill(getpid (), (int)INUM(sig)) ? BOOL_F : BOOL_T;
#       else
  return raise((int)INUM(sig)) ? BOOL_F : BOOL_T;
#       endif
#      else
  return raise((int)INUM(sig)) ? BOOL_F : BOOL_T;
#      endif
#     else
  return raise((int)INUM(sig)) ? BOOL_F : BOOL_T;
#     endif
#    endif
}
#   endif
#  endif
# endif
#endif
#ifdef TICKS
unsigned int tick_count = 0, ticken = 0;
SCM *loc_tick_signal;
void tick_signal()
{
  if (ticken && NIMP(*loc_tick_signal)) {
    ticken = 0;
    apply(*loc_tick_signal, EOL, EOL);
  }
}
static char s_ticks[] = "ticks";
SCM lticks(i)
     SCM i;
{
  SCM j = ticken ? tick_count : 0;
  if (!UNBNDP(i)) ticken = tick_count = INUM(i);
  return MAKINUM(j);
}
#endif

#ifdef SIGPIPE
static SIGRETTYPE (*oldpipe) ();
#endif

int dumped = 0;			/* Is this an invocation of unexec exe? */
#ifndef LACK_SBRK
long scm_init_brk, scm_dumped_brk;
#endif

#ifdef SHORT_ALIGN
typedef short STACKITEM;
#else
typedef long STACKITEM;
#endif
/* See scm.h for definition of P */
void  init_storage P((STACKITEM *stack_start_ptr, long init_heap_size));

void init_scm( iverbose, buf0stdin, init_heap_size )
     int iverbose;
     int buf0stdin;
     long init_heap_size;
{
  STACKITEM i;
  if (2 <= iverbose) init_banner();
  if (!dumped) {
    init_types();
    init_tables();
    init_storage(&i, init_heap_size); /* CONT(rootcont)->stkbse gets set here */
  }
  if (buf0stdin) CAR(def_inp) |= BUF0;
  else CAR(def_inp) &= ~BUF0;
  if (!dumped) {
    init_features();
    init_subrs();
    init_io();
    init_scl();
    init_eval();
    init_time();
    init_repl( iverbose );
    init_unif();
  }
  else {
    reset_time();
  }
}

static void init_sig1(scm_err, signo, handler)
     int scm_err;
     int signo;
     SIGRETTYPE (*handler)();
{
  int i = scm_err - SIGNAL_BASE;
  ASSERT(i < NUM_SIGNALS, MAKINUM(i), OUTOFRANGE, "init_sig1");
  sigdesc[i].signo = signo;
  sigdesc[i].nsig = handler;
  sigdesc[i].osig = signal(signo, handler);
}
void init_signals()
{
  init_sig1(INT_SIGNAL, SIGINT, scmable_signal);
#ifdef SIGHUP
  init_sig1(HUP_SIGNAL, SIGHUP, scmable_signal);
#endif
#ifdef FLOATS
  init_sig1(FPE_SIGNAL, SIGFPE, err_signal);
#endif
#ifdef SIGBUS
  init_sig1(BUS_SIGNAL, SIGBUS, err_signal);
#endif
#ifdef SIGSEGV			/* AMIGA lacks! */
  init_sig1(SEGV_SIGNAL, SIGSEGV, err_signal);
#endif
#ifdef SIGALRM
  alarm(0);			/* kill any pending ALRM interrupts */
  init_sig1(ALRM_SIGNAL, SIGALRM, scmable_signal);
# ifdef SIGPROF
  init_sig1(PROF_SIGNAL, SIGPROF, scmable_signal);
# endif
#endif
#ifdef SIGPIPE
  oldpipe = signal(SIGPIPE, SIG_IGN);
#endif
#ifdef ultrix
  siginterrupt(SIGINT, 1);
  siginterrupt(SIGALRM, 1);
  siginterrupt(SIGHUP, 1);
  siginterrupt(SIGPIPE, 1);
#endif /* ultrix */
}
/* This is used in preparation for a possible fork().  Ignore all
   signals before the fork so that child will catch only if it
   establishes a handler */
void ignore_signals()
{
  int i = NUM_SIGNALS;
#ifdef ultrix
  siginterrupt(SIGINT, 0);
  siginterrupt(SIGALRM, 0);
  siginterrupt(SIGHUP, 0);
  siginterrupt(SIGPIPE, 0);
#endif /* ultrix */
  while (i--)
    if (sigdesc[i].signo)
      signal(sigdesc[i].signo, SIG_DFL);
  /* Some documentation claims that ALRMs are cleared accross forks.
     If this is not always true then the value returned by alarm(0)
     will have to be saved and unignore_signals() will have to
     reinstate it. */
  /* This code should be necessary only if the forked process calls
     alarm() without establishing a handler: */
#ifdef SIGALRM
  /* oldalrm = signal(SIGALRM, SIG_DFL); */
#endif
  /* These flushes are per warning in man page on fork(). */
  fflush(stdout);
  fflush(stderr);
#ifdef SIG_UNBLOCK
  {
    sigset_t set;
    sigfillset(&set);
    sigprocmask(SIG_UNBLOCK, &set, 0);
  }
#endif
}

void unignore_signals()
{
  int i = NUM_SIGNALS;
  while (i--) 
    if (sigdesc[i].signo)
      signal(sigdesc[i].signo, sigdesc[i].nsig);
#ifdef ultrix
  siginterrupt(SIGINT, 1);
  siginterrupt(SIGALRM, 1);
  siginterrupt(SIGHUP, 1);
  siginterrupt(SIGPIPE, 1);
#endif /* ultrix */
}

void restore_signals()
{
  int i = NUM_SIGNALS;
#ifdef ultrix
  siginterrupt(SIGINT, 0);
  siginterrupt(SIGALRM, 0);
  siginterrupt(SIGHUP, 0);
  siginterrupt(SIGPIPE, 0);
#endif /* ultrix */
#ifdef SIGALRM
  alarm(0);			/* kill any pending ALRM interrupts */
# ifdef SIGPROF
  scm_proftimer(BOOL_F);	/* Turn off interval timer interrupt */
# endif
#endif
  while (i--)
    if (sigdesc[i].signo) 
      signal(sigdesc[i].signo, sigdesc[i].osig);
#ifdef SIGPIPE
  oldpipe = signal(SIGPIPE, SIG_IGN);
#endif
}
int run_scm(argc, argv, iverbose, buf0stdin, initpath)
     int argc;
     char **argv;
     int iverbose;
     int buf0stdin;
     char *initpath;
{
  SCM i;
  do {
    i = 0L;
    if ((2 <= argc) && argv[1] && (0==strncmp("-a", argv[1], 2))) {
      char *str = (0==argv[1][2] && 3 <= argc && argv[2]) ?argv[2]:&argv[1][2];
      do {
	switch (*str) {
	case DIGITS:
	  i = i * 10 + (*str - '0');
	  if (i <= 10000L) continue; /* the size limit should match Init.scm */
	default:
	  i = 0L;
	}
	break;
      } while (* ++str);
    }
    init_scm(iverbose, buf0stdin, (0 >= i) ? 0L : 1024L * i); /* size in Kb */
    progargs = EOL;
    progargs = makfromstrs(argc, argv);

#ifdef HAVE_DYNL
    /* init_dynl() must check dumped to avoid redefining subrs */
    init_dynl();
#endif

    if (!dumped) {
#ifdef INITS
      INITS;			/* call initialization of extension files */
#endif
    }
    init_signals();
    i = repl_driver(initpath);
    restore_signals();
#ifdef TICKS
    ticken = 0;
#endif
#ifdef FINALS
    FINALS;			/* call shutdown of extensions files */
#endif /* for compatability with older modules */
    /* call finalization of user extensions */
    while (num_finals--) (finals[num_finals])();
    final_repl();
    free_storage();		/* free all allocated memory */
    if (i) break;
    dumped = 0;
    if (2 <= iverbose) fputs(";RESTART\n", stderr);
  } while (!0);
  if (2 <= iverbose) fputs(";EXIT\n", stderr);
  fflush(stderr);
  return (int)INUM(i);
}

#ifdef __CYGWIN32__
# define SYSTNAME "unix"
# define DIRSEP "/"
#endif
#ifdef vms
# define SYSTNAME "vms"
#endif
#ifdef unix
# define DIRSEP "/"
# ifndef MSDOS			/* DJGPP defines both */
#  define SYSTNAME "unix"
# endif
#endif
#ifdef MWC
# define SYSTNAME "coherent"
# define DIRSEP "/"
#endif
#ifdef _Windows
# define SYSTNAME "windows"
# define DIRSEP "\\"
#else
# ifdef MSDOS
#  define SYSTNAME "ms-dos"
#  ifndef unix
#   define DIRSEP "\\"
#  endif
# endif
#endif
#ifdef __EMX__
# define SYSTNAME "os/2"
# define DIRSEP "\\"
#endif
#ifdef __IBMC__
# define SYSTNAME "os/2"
# define DIRSEP "\\"
#endif
#ifdef THINK_C
# define SYSTNAME "thinkc"
# define DIRSEP ":"
#endif
#ifdef __MWERKS__
# define SYSTNAME "macos"
# define DIRSEP ":"
#endif
#ifdef AMIGA
# define SYSTNAME "amiga"
# define DIRSEP "/"
#endif
#ifdef atarist
# define SYSTNAME "atarist"
# define DIRSEP "\\"
#endif
#ifdef mach
# define SYSTNAME "mach"
# define DIRSEP "/"
#endif
#ifdef ARM_ULIB
# define SYSTNAME "acorn"
#endif
#ifdef nosve
# define DIRSEP "."
#endif

SCM softtype()
{
#ifdef nosve
  return CAR(intern("nosve", 5));
#else
  return CAR(intern(SYSTNAME, sizeof SYSTNAME/sizeof(char) -1));
#endif
}

/* The argument giving the location of a script file, or NULL. */
static char *script_arg = 0;
/* The original argv[0], used to find executable. */
static char *arg0 = 0;
char *execpath = 0;

#ifndef RTL

# ifndef DIRSEP
#  define DIRSEP "/"
# endif
# ifndef GENERIC_NAME
#  define GENERIC_NAME "scm"
# endif

int main(argc, argv)
     int argc;
     char **argv;
{
  int retval, buf0stdin = 0, nargc;
  char *getenvpath, *implpath = 0, **nargv;
# ifdef macintosh
  char *foo[] = { "scm" };
  if (argc == 0) {
    argc = 1;
    argv = foo;
  }
# endif
  execpath = 0;
  arg0 = argv[0];
  /*{
    char ** argvv = argv;
    for (;*argvv;argvv++) {
      fputs(*argvv,stderr);
      fputs(" ",stderr);
    }
    fputs("\n",stderr);
    }*/
  /* The following applies only to SCSH style scripts, execpath
     does not (cannot?) work properly for simple #! scripts */
  if ((nargv = script_process_argv(argc, argv))) {
    script_arg = argv[2];
    nargc = script_count_argv(nargv);
  }
  else {
    nargv = argv;
    nargc = argc;
  }
# ifndef LACK_SBRK
  if (dumped)
    scm_dumped_brk = (long)sbrk(0);
  else
    scm_init_brk = (long)sbrk(0);
# endif
  if (!dumped) {
# ifndef nosve
    getenvpath = getenv("SCM_INIT_PATH");
    if (getenvpath) implpath = scm_cat_path(0L, getenvpath, 0L);
    if (implpath) {
      /* The value of the environment variable supersedes other
	 locations, as long as the file exists. */
      implpath = scm_try_path(implpath);
      if (!implpath) {
	fputs("Value of SCM_INIT_PATH (=\"", stderr);
	fputs(getenvpath, stderr);
	fputs("\") not found; Trying elsewhere\n", stderr);
      }
    }
# endif
    if (!implpath) {
      execpath = scm_find_executable();
      if (execpath) {
	implpath = scm_find_impl_file(execpath,
				      GENERIC_NAME, INIT_FILE_NAME, DIRSEP);
	/* fprintf(stderr, "scm_find_impl_file returned \"%s\"\n", implpath); fflush(stderr); */
      }
    }
# ifdef IMPLINIT
    /* Should IMPLINIT somehow be visible if we've been dumped? */
    if (!implpath) implpath = scm_cat_path(0L, IMPLINIT, 0L);
# endif
  }
# ifndef GO32
  if (isatty(fileno(stdin))) {
    buf0stdin = !0;		/* stdin gets marked BUF0 in init_scm() */
#  ifndef NOSETBUF
#   ifndef _DCC
#    ifndef ultrix
#     ifndef __WATCOMC__
#      ifndef macintosh
#       if (__TURBOC__ != 1)
#        ifndef _Windows
    setbuf(stdin, 0);		/* Often setbuf isn't actually required */
#        endif
#       endif
#      endif
#     endif
#    endif
#   endif
  }
#  endif
# endif
  retval = run_scm(nargc, nargv,
		   (isatty(fileno(stdin)) && isatty(fileno(stdout)))
		   ? (nargc <= 1) ? 2 : 1 : 0,
		   buf0stdin,
		   implpath ? implpath : "");
  if (implpath) free(implpath);
  if (execpath) free(execpath);
  execpath = 0;
  return retval;
}
#endif

char *scm_find_executable()
{
  char *execpath = 0;
#ifndef macintosh
# ifdef unix
#  ifndef MSDOS
  if (script_arg)
    execpath = script_find_executable(script_arg);
#  endif
# endif
  if (!execpath && arg0) execpath = dld_find_executable(arg0);
  /* fprintf(stderr, "scm_find_executable: execpath = %s\n", execpath); fflush(stderr); */
#endif
  return execpath;
}

/* Initialized in repl.c */
char s_scm_find_impl[] = "find-init-file";
SCM scm_find_impl(execpath)
     SCM execpath;
{
  SCM res;
  char *implpath = 0;
  ASSERT(NIMP(execpath) && STRINGP(execpath), execpath, ARG1, "find-init-file");
  implpath = scm_find_impl_file(CHARS(execpath),
				GENERIC_NAME, INIT_FILE_NAME, DIRSEP);
  res = (implpath ? makfrom0str(implpath) : BOOL_F);
  if (implpath) free(implpath);
  return res;
}


#ifndef _Windows
char s_system[] = "system";
SCM lsystem(cmd)
     SCM cmd;
{
  ASSERT(NIMP(cmd) && STRINGP(cmd), cmd, ARG1, s_system);
  ignore_signals();
# ifdef AZTEC_C
  cmd = MAKINUM(Execute(CHARS(cmd), 0, 0));
# else
  cmd = MAKINUM(0L+system(CHARS(cmd)));
# endif
  unignore_signals();
  return cmd;
}
#endif

char s_getenv[] = "getenv";
char *getenv();
SCM lgetenv(nam)
     SCM nam;
{
  char *val;
  ASSERT(NIMP(nam) && STRINGP(nam), nam, ARG1, s_getenv);
  val = getenv(CHARS(nam));
  if (!val) return BOOL_F;
  return makfrom0str(val);
}

#ifdef vms
# include <descrip.h>
# include <ssdef.h>
char s_ed[] = "ed";
SCM ed(fname)
     SCM fname;
{
  struct dsc$descriptor_s d;
  ASSERT(NIMP(fname) && STRINGP(fname), fname, ARG1, s_ed);
  d.dsc$b_dtype = DSC$K_DTYPE_T;
  d.dsc$b_class = DSC$K_CLASS_S;
  d.dsc$w_length = LENGTH(fname);
  d.dsc$a_pointer = CHARS(fname);
  /* I don't know what VMS does with signal handlers across the
     edt$edit call. */
  ignore_signals();
  edt$edit(&d);
  unignore_signals();
  return fname;
}
SCM vms_debug()
{
  lib$signal(SS$_DEBUG);
  return UNSPECIFIED;
}
#endif

static iproc subr0s[] = {
	{"software-type", softtype},
	{"scm_init_extensions", scm_init_extensions},
#ifdef vms
	{"vms-debug", vms_debug},
#endif
#ifdef SIGALRM
# ifndef AMIGA
#  ifndef __CYGWIN32__
	{"pause", l_pause},
#  endif
# endif
#endif
	{0, 0}};
static iproc subr1s[] = {
	{s_getenv, lgetenv},
#ifndef _Windows
	{s_system, lsystem},
#endif
#ifdef vms
	{s_ed, ed},
#endif
#ifdef SIGALRM
	{s_alarm, lalarm},
# ifdef SIGPROF
	{s_proftimer, scm_proftimer},
# endif
#endif
#ifndef AMIGA
# ifndef _Windows
	{s_sleep, l_sleep},
# endif
#endif
#ifndef GO32
# ifndef sun
#  ifndef _WIN32
	{s_raise, l_raise},
#  endif
# endif
#endif
	{0, 0}};

SCM *loc_features;
void add_feature(str)
     char* str;
{
  *loc_features = cons(CAR(intern(str, strlen(str))), *loc_features);
}
void init_features()
{
  loc_features = &CDR(sysintern("*features*", EOL));
  init_iprocs(subr0s, tc7_subr_0);
  init_iprocs(subr1s, tc7_subr_1);
#ifdef TICKS
  loc_tick_signal = &CDR(sysintern("ticks-interrupt", UNDEFINED));
  make_subr(s_ticks, tc7_subr_1o, lticks);
#endif
#ifdef RECKLESS
  add_feature("reckless");
#endif
#ifndef _Windows
  add_feature(s_system);
#endif
#ifdef vms
  add_feature(s_ed);
#endif
  sysintern("*scm-version*", makfrom0str(SCMVERSION));
}