path: root/scm.c

/* Copyright (C) 1990-1999 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, 59 Temple Place, Suite 330, Boston, MA 02111, 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" Initialization and interrupt code.
   Author: Aubrey Jaffer */

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

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

/* See scm.h for definition of P */

#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
# ifdef __amigados__
#  include <unistd.h>
# endif
#endif

void	init_sbrk 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	final_repl P((void));

void init_banner()
{
  fputs("SCM version "SCMVERSION", Copyright (C) 1990-1999 \
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
  init_user_scm();
  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, n;
  unsigned long mask = 1L;
  if (output_deferred) {
    output_deferred = 0;
    lflush(sys_errp);
  }
  for (n = 0; SIG_deferred && n < NUM_SIGNALS; n++) {
    if (SIG_deferred & mask) {
      i = n + SIGNAL_BASE;
      SIG_deferred &= ~mask;
      if (i != handle_it(i))
	wta(UNDEFINED, (char *)i, "");
    }
    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, 0L);
#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 __HIGHC__
# undef SIGALRM
#endif
#ifdef LACK_SETITIMER
# undef SIGPROF
#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_setitimer[] = "setitimer";
static SCM setitimer_iv[3];
/* VALUE and INTERVAL are milliseconds */
SCM scm_setitimer(which, value, interval)
     SCM which, value, interval;
{
  struct itimerval tval, oval;
  int w;
#  ifdef ITIMER_REAL
  if (which==setitimer_iv[0]) {
    w = ITIMER_REAL;
    goto doit;
  }
#  endif
#  ifdef ITIMER_VIRTUAL
  if (which==setitimer_iv[1]) {
    w = ITIMER_VIRTUAL;
    goto doit;
  }
#  endif
#  ifdef ITIMER_PROF
  if (which==setitimer_iv[2]) {
    w = ITIMER_PROF;
    goto doit;
  }
#  endif
  return BOOL_F;
 doit:
  if (BOOL_T==value)
    SYSCALL(w = getitimer(w, &oval););
  else {
    if (BOOL_F==value) value = INUM0;
    ASSERT(INUMP(value), value, ARG2, s_setitimer);
    if (BOOL_F==interval) interval = INUM0;
    ASSERT(INUMP(interval), interval, ARG3, s_setitimer);
    tval.it_value.tv_sec = INUM(value) / 1000;
    tval.it_value.tv_usec = (INUM(value) % 1000)*1000;
    tval.it_interval.tv_sec = INUM(interval) / 1000;
    tval.it_interval.tv_usec = (INUM(interval) % 1000)*1000;
    SYSCALL(w = setitimer(w, &tval, &oval););
  }
  if (w) return BOOL_F;
  return cons2(MAKINUM(oval.it_value.tv_usec/1000 +
		       oval.it_value.tv_sec*1000),
	       MAKINUM(oval.it_interval.tv_usec/1000 +
		       oval.it_interval.tv_sec*1000),
	       EOL);
}
# 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 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
#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? */

#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) SCM_PORTFLAGS(def_inp) |= BUF0;
  else SCM_PORTFLAGS(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();
#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
  }
}

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
# ifdef SIGVTALRM
  init_sig1(VTALRM_SIGNAL, SIGVTALRM, 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, 0L);
  }
#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;
#ifdef ultrix
  siginterrupt(SIGINT, 0);
  siginterrupt(SIGALRM, 0);
  siginterrupt(SIGHUP, 0);
  siginterrupt(SIGPIPE, 0);
#endif /* ultrix */
#ifdef SIGALRM
# ifndef SIGPROF
  alarm(0);			/* kill any pending ALRM interrupts */
# else
  i = sizeof(setitimer_iv)/sizeof(SCM);
  while (i--)
    scm_setitimer(setitimer_iv[i], BOOL_F, BOOL_F);
# endif
#endif
  i = NUM_SIGNALS;
  while (i--)
    if (sigdesc[i].signo)
      signal(sigdesc[i].signo, sigdesc[i].osig);
#ifdef SIGPIPE
  oldpipe = signal(SIGPIPE, SIG_IGN);
#endif
}

void scm_init_from_argv(argc, argv, script_arg, iverbose, buf0stdin)
     int argc;
     char **argv;
     char *script_arg;
     int iverbose;
     int buf0stdin;
{
  long 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);
  sysintern("*script*", script_arg ? makfrom0str(script_arg) : BOOL_F);
}
void final_scm(freeall)
     int freeall;
{
#ifdef TICKS
  ticken = 0;
#endif
#ifdef FINALS
  FINALS;			/* call shutdown of extensions files */
#endif /* for compatability with older modules */
  /* call finalization of user extensions */
  {
    int k = num_finals;
    while (k--) (finals[k])();
  }
  final_repl();
  if (freeall) free_storage();	/* free all allocated memory */
}

#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
#ifdef __amigados__
# define SYSTNAME "amiga"
# define DIRSEP "/"
#endif
const char dirsep[] = DIRSEP;

SCM softtype()
{
#ifdef nosve
  return CAR(sysintern("nosve", UNDEFINED));
#else
  return CAR(sysintern(SYSTNAME, UNDEFINED));
#endif
}

int init_buf0(inport)
     FILE *inport;
{
  if (isatty(fileno(inport))) {
#ifndef NOSETBUF
# ifndef _DCC
#  ifndef ultrix
#   ifndef __WATCOMC__
#    ifndef macintosh
#     if (__TURBOC__ != 1)
#      ifndef _Windows
    setbuf(inport, 0L);		/* Often setbuf isn't actually required */
#      endif
#     endif
#    endif
#   endif
#  endif
# endif
    return !0;			/* stdin gets marked BUF0 in init_scm() */
  }
#endif
  return 0;
}

char *execpath = 0;
char s_no_execpath[] = "no execpath";
#define s_execpath (s_no_execpath+3)
SCM scm_execpath(newpath)
     SCM newpath;
{
  SCM retval = execpath ? makfrom0str(execpath) : BOOL_F;
  if (UNBNDP(newpath))
    return retval;
  if (FALSEP(newpath)) {
    if (execpath) free(execpath);
    execpath = 0;
    return retval;
  }
  ASSERT(NIMP(newpath) && STRINGP(newpath), newpath, ARG1, s_execpath);
  if (execpath) free(execpath);
  execpath = (char *)malloc((sizet)(LENGTH(newpath) + 1));
  ASSERT(execpath, newpath, NALLOC, s_execpath);
  strncpy(execpath, CHARS(newpath), LENGTH(newpath) + 1);
  return retval;
}
char *scm_find_execpath(argc, argv, script_arg)
     int argc;
     char **argv;
     char *script_arg;
{
  char *exepath = 0;
#ifndef macintosh
# ifdef unix
#  ifndef MSDOS
  if (script_arg) exepath = script_find_executable(script_arg);
#  endif
# endif
  if (!exepath && argv[0]) exepath = dld_find_executable(argv[0]);
/*fprintf(stderr, "scm_find_execpath: argv[0] = %s; script_arg = %s; exepath = %s\n", argv[0], script_arg, exepath); fflush(stderr); */
#endif
  return exepath;
}

#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},
#endif
#ifndef AMIGA
# ifndef _Windows
	{s_sleep, l_sleep},
# endif
#endif
#ifndef sun
# ifndef _WIN32
	{s_raise, l_raise},
# endif
#endif
	{0, 0}};

SCM *loc_features;
void add_feature(str)
     char* str;
{
  *loc_features = cons(CAR(sysintern(str, UNDEFINED)), *loc_features);
}
void init_features()
{
  loc_features = &CDR(sysintern("*features*", EOL));
  init_iprocs(subr0s, tc7_subr_0);
  init_iprocs(subr1s, tc7_subr_1);
  make_subr(s_execpath, tc7_subr_1o, scm_execpath);
#ifdef SIGALRM
# ifdef SIGPROF
  make_subr(s_setitimer, tc7_subr_3, scm_setitimer);
  setitimer_iv[0] = CAR(sysintern("real", UNDEFINED));
  setitimer_iv[1] = CAR(sysintern("virtual", UNDEFINED));
  setitimer_iv[2] = CAR(sysintern("profile", UNDEFINED));
# endif
#endif
#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));
}