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_eval P((void));
void	init_features P((void));
void	init_io P((void));
void	init_ioext 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_subrs P((void));
void	init_tables P((void));
void	init_time P((void));
void	init_types P((void));
void	init_unif P((void));
void	init_ramap 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

#ifdef SIGHUP
static SIGRETTYPE hup_signal(sig)
     int sig;
{
	signal(SIGHUP, hup_signal);
	wta(UNDEFINED, (char *)HUP_SIGNAL, "");
}
#endif
static SIGRETTYPE int_signal(sig)
     int sig;
{
	sig = errno;
	signal(SIGINT, int_signal);
	if (ints_disabled) sig_deferred = 1;
	else han_sig();
	errno = sig;
}

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

#ifndef SIGFPE
# undef FLOATS
#endif

#ifdef FLOATS
static SIGRETTYPE fpe_signal(sig)
     int sig;
{
	signal(SIGFPE, fpe_signal);
	wta(UNDEFINED, (char *)FPE_SIGNAL, "");
}
#endif
#ifdef SIGBUS
static SIGRETTYPE bus_signal(sig)
     int sig;
{
	signal(SIGBUS, bus_signal);
	wta(UNDEFINED, (char *)BUS_SIGNAL, "");
}
#endif
#ifdef SIGSEGV			/* AMIGA lacks! */
static SIGRETTYPE segv_signal(sig)
     int sig;
{
	signal(SIGSEGV, segv_signal);
	wta(UNDEFINED, (char *)SEGV_SIGNAL, "");
}
#endif
#ifdef atarist
# undef SIGALRM			/* only available via MiNT libs */
#endif
#ifdef GO32
# undef SIGALRM
#endif
#ifdef __HIGHC__
# undef SIGALRM
#endif
#ifdef SIGALRM
static SIGRETTYPE alrm_signal(sig)
     int sig;
{
	sig = errno;
	signal(SIGALRM, alrm_signal);
	if (ints_disabled) alrm_deferred = 1;
	else han_alrm();
	errno = sig;
}
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);
}
# ifndef AMIGA
SCM l_pause()
{
  pause();
  return UNSPECIFIED;
}
# 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
  return MAKINUM(j);
#  endif
}
# endif
#endif

#ifndef _WIN32
# ifndef GO32
#  ifndef sun
/* 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
  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
#   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 SIGHUP
static SIGRETTYPE (*oldhup)();
#endif
static SIGRETTYPE (*oldint)();
#ifdef FLOATS
static SIGRETTYPE (*oldfpe)();
#endif
#ifdef SIGBUS
static SIGRETTYPE (*oldbus)();
#endif
#ifdef SIGSEGV			/* AMIGA lacks! */
static SIGRETTYPE (*oldsegv)();
#endif
#ifdef SIGALRM
static SIGRETTYPE (*oldalrm) ();
#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) CAR(def_inp) |= BUF0;
    init_features();
    init_subrs();
    init_io();
    init_scl();
    init_eval();
    init_time();
    init_repl( iverbose );
    init_unif();
  }}

void init_signals()
{
  oldint = signal(SIGINT, int_signal);
#ifdef SIGHUP
  oldhup = signal(SIGHUP, hup_signal);
#endif
#ifdef FLOATS
  oldfpe = signal(SIGFPE, fpe_signal);
#endif
#ifdef SIGBUS
  oldbus = signal(SIGBUS, bus_signal);
#endif
#ifdef SIGSEGV			/* AMIGA lacks! */
  oldsegv = signal(SIGSEGV, segv_signal);
#endif
#ifdef SIGALRM
  alarm(0);			/* kill any pending ALRM interrupts */
  oldalrm = signal(SIGALRM, alrm_signal);
#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()
{
#ifdef ultrix
  siginterrupt(SIGINT, 0);
  siginterrupt(SIGALRM, 0);
  siginterrupt(SIGHUP, 0);
  siginterrupt(SIGPIPE, 0);
#endif /* ultrix */
  signal(SIGINT, SIG_IGN);
#ifdef SIGHUP
  signal(SIGHUP, SIG_DFL);
#endif
#ifdef FLOATS
  signal(SIGFPE, SIG_DFL);
#endif
#ifdef SIGBUS
  signal(SIGBUS, SIG_DFL);
#endif
#ifdef SIGSEGV			/* AMIGA lacks! */
  signal(SIGSEGV, SIG_DFL);
#endif
  /* 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 neccessary 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);
}

void unignore_signals()
{
  signal(SIGINT, int_signal);
#ifdef SIGHUP
  signal(SIGHUP, hup_signal);
#endif
#ifdef FLOATS
  signal(SIGFPE, fpe_signal);
#endif
#ifdef SIGBUS
  signal(SIGBUS, bus_signal);
#endif
#ifdef SIGSEGV			/* AMIGA lacks! */
  signal(SIGSEGV, segv_signal);
#endif
#ifdef SIGALRM
  signal(SIGALRM, alrm_signal);
#endif
#ifdef ultrix
  siginterrupt(SIGINT, 1);
  siginterrupt(SIGALRM, 1);
  siginterrupt(SIGHUP, 1);
  siginterrupt(SIGPIPE, 1);
#endif /* ultrix */
}

void restore_signals()
{
#ifdef ultrix
  siginterrupt(SIGINT, 0);
  siginterrupt(SIGALRM, 0);
  siginterrupt(SIGHUP, 0);
  siginterrupt(SIGPIPE, 0);
#endif /* ultrix */
  signal(SIGINT, oldint);
#ifdef SIGHUP
  signal(SIGHUP, oldhup);
#endif
#ifdef FLOATS
  signal(SIGFPE, oldfpe);
#endif
#ifdef SIGBUS
  signal(SIGBUS, oldbus);
#endif
#ifdef SIGSEGV			/* AMIGA lacks! */
  signal(SIGSEGV, oldsegv);
#endif
#ifdef SIGPIPE
  signal(SIGPIPE, oldpipe);
#endif
#ifdef SIGALRM
  alarm(0);			/* kill any pending ALRM interrupts */
  signal(SIGALRM, oldalrm);
#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);

    if (!dumped) {
#ifdef HAVE_DYNL
      init_dynl();
#endif
#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 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 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 INIT_FILE_NAME "Init_scm";
# define DIRSEP "."
#endif

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

#ifndef RTL

# ifndef INIT_FILE_NAME
#  define INIT_FILE_NAME "Init.scm"
# endif
# ifndef DIRSEP
#  define DIRSEP "/"
# endif
# ifndef GENERIC_NAME
#  define GENERIC_NAME "scm"
# endif

char *execpath = 0;
int main(argc, argv)
     int argc;
     char **argv;
{
  int retval, buf0stdin = 0, nargc;
  char *getenvpath, *implpath = 0, **nargv;
  
  execpath = 0;
  if ((nargv = script_process_argv(argc, argv))) {
    nargc = script_count_argv(nargv);
# ifdef unix
#  ifndef MSDOS
    execpath = script_find_executable(argv[2]);
#  endif
# endif
  }
  else {
    nargv = argv;
    nargc = argc;
  }
  /* fprintf(stderr, "execpath = %s\n", execpath); fflush(stderr); */
  if (!execpath) execpath = dld_find_executable(argv[0]);

# 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 (execpath && (!implpath)) {
    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
  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 THINK_C
#       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

#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
	{"pause", l_pause},
# 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 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));
}