/* Scheme implementation intended for JACAL.
   Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Aubrey Jaffer.

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 1, 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 program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

The author can be reached at jaffer@ai.mit.edu or
Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880
*/

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

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

#ifdef HAVE_UNISTD_H
#include <unistd.h>
#ifndef STDC_HEADERS
char *getenv P ((const char *name));
#endif
#else
#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 alarm P ((unsigned int));
int system P((const char *));
#endif
#endif

void scm_final_repl P ((void));
void init_dynl P ((void));
void scm_init_eval P ((void));
void scm_init_features P ((void));
void scm_init_io P ((void));
void scm_init_ioext P ((void));
void scm_init_repl P ((int iverbose));
void scm_init_sc2 P ((void));
void scm_init_scl P ((void));
void scm_init_signals P ((void));
void scm_init_subrs P ((void));
void scm_init_tables P ((void));
void scm_init_time P ((void));
void scm_init_types P ((void));
void scm_init_unif P ((void));
void init_ramap P ((void));

void 
scm_init_banner ()
{
  fputs ("SCM version ", stderr);
  fputs (SCMVERSION, stderr);
  fputs (", Copyright (C) 1990, 1991, 1992, 1993, 1994 Aubrey Jaffer.\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);
  scm_wta (SCM_UNDEFINED, (char *) HUP_SIGNAL, "");
}
#endif
static SIGRETTYPE 
int_signal (sig)
     int sig;
{
  sig = errno;
  signal (SIGINT, int_signal);
  if (scm_ints_disabled)
    scm_sig_deferred = 1;
  else
    scm_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);
  scm_wta (SCM_UNDEFINED, (char *) FPE_SIGNAL, "");
}
#endif
#ifdef SIGBUS
static SIGRETTYPE 
bus_signal (sig)
     int sig;
{
  signal (SIGBUS, bus_signal);
  scm_wta (SCM_UNDEFINED, (char *) BUS_SIGNAL, "");
}
#endif
#ifdef SIGSEGV			/* AMIGA lacks! */
static SIGRETTYPE 
segv_signal (sig)
     int sig;
{
  signal (SIGSEGV, segv_signal);
  scm_wta (SCM_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 (scm_ints_disabled)
    scm_alrm_deferred = 1;
  else
    scm_han_alrm ();
  errno = sig;
}
static char s_alarm[] = "alarm";
SCM 
scm_l_alarm (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 
scm_l_pause ()
{
  pause ();
  return UNSPECIFIED;
}
#endif
#endif /* SIGALRM */

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

#ifndef GO32
/* int raise P((int sig)); */
static char s_raise[] = "raise";
SCM scm_l_raise(sig)
     SCM sig;
{
  ASSERT(INUMP(sig), sig, ARG1, s_raise);
# ifdef vms
  return MAKINUM(gsignal((int)INUM(sig)));
# else
  return kill (getpid(), (int)INUM(sig)) ? BOOL_F : BOOL_T;
# endif
}
#endif

#ifdef TICKS
unsigned int scm_tick_count = 0, scm_ticken = 0;
SCM *scm_loc_tick_signal;
void 
scm_tick_signal ()
{
  if (scm_ticken && NIMP (*scm_loc_tick_signal))
    {
      scm_ticken = 0;
      scm_apply (*scm_loc_tick_signal, EOL, EOL);
    }
}
static char s_ticks[] = "ticks";
SCM 
scm_lticks (i)
     SCM i;
{
  SCM j = scm_ticken ? scm_tick_count : 0;
  if (!UNBNDP (i))
    scm_ticken = scm_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

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

void 
scm_init_scm (iverbose, init_heap_size)
     int iverbose;
     long init_heap_size;
{
  STACKITEM i;
  if (2 <= iverbose)
    scm_init_banner ();
  scm_init_types ();
  scm_init_tables ();
  scm_init_storage (&i, init_heap_size);	/* BASE(rootcont) gets set here */
  scm_init_features ();
  scm_init_subrs ();
  scm_init_io ();
  scm_init_scl ();
  scm_init_eval ();
  scm_init_time ();
  scm_init_repl (iverbose);
  scm_init_unif ();
  init_ramap ();
}

void 
scm_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 
scm_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 scm_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 
scm_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 
scm_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
}

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

char scm_s_getenv[] = "getenv";
char *getenv();
SCM scm_lgetenv(nam)
SCM nam;
{
  char *val;
  ASSERT(NIMP(nam) && STRINGP(nam), nam, ARG1, scm_s_getenv);
  val = getenv(CHARS(nam));
  if (!val) return BOOL_F;
  return scm_makfromstr(val, (sizet)strlen(val), 0);
}

#ifdef vms
# define SYSTNAME "VMS"
#endif
#ifdef unix
# define SYSTNAME "UNIX"
#endif
#ifdef MWC
# define SYSTNAME "COHERENT"
#endif
#ifdef _Windows
# define SYSTNAME "WINDOWS"
#else
# ifdef MSDOS
#  define SYSTNAME "MS-DOS"
# endif
#endif
#ifdef __EMX__
# define SYSTNAME "OS/2"
#endif
#ifdef __IBMC__
# define SYSTNAME "OS/2"
#endif
#ifdef THINK_C
# define SYSTNAME "THINKC"
#endif
#ifdef AMIGA
# define SYSTNAME "AMIGA"
#endif
#ifdef atarist
# define SYSTNAME "ATARIST"
#endif
#ifdef mach
# define SYSTNAME "MACH"
#endif
#ifdef ARM_ULIB
# define SYSTNAME "ACORN"
#endif

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

#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. */
  scm_ignore_signals();
  edt$edit(&d);
  scm_unignore_signals();
  return fname;
}
SCM vms_debug()
{
  lib$signal(SS$_DEBUG);
  return UNSPECIFIED;
}
#endif

static scm_iproc subr0s[] = {
	{"software-type", scm_softtype},
	{"init_extensions", scm_init_extensions},
#ifdef vms
	{"vms-debug", vms_debug},
#endif
#ifdef SIGALRM
# ifndef AMIGA
	{"pause", scm_l_pause},
# endif
#endif
	{0, 0}};
static scm_iproc subr1s[] = {
	{scm_s_getenv, scm_lgetenv},
#ifndef _Windows
	{scm_s_system, scm_lsystem},
#endif
#ifdef vms
	{s_ed, ed},
#endif
#ifdef SIGALRM
	{s_alarm, scm_l_alarm},
#endif
#ifndef AMIGA
# ifndef _Windows
	{s_sleep, scm_l_sleep},
# endif
#endif
#ifndef GO32
	{s_raise, scm_l_raise},
#endif
	{0, 0}};

SCM *scm_loc_features;
void scm_add_feature(str)
     char* str;
{
  *scm_loc_features = scm_cons(CAR(scm_intern(str, strlen(str))), *scm_loc_features);
}
void scm_init_features()
{
  scm_loc_features = &CDR(scm_sysintern("*features*", EOL));
  scm_init_iprocs(subr0s, tc7_subr_0);
  scm_init_iprocs(subr1s, tc7_subr_1);
#ifdef TICKS
  scm_loc_tick_signal = &CDR(scm_sysintern("ticks-interrupt", SCM_UNDEFINED));
  scm_make_subr(s_ticks, tc7_subr_1o, scm_lticks);
#endif
#ifdef RECKLESS
  scm_add_feature("reckless");
#endif
#ifndef _Windows
  scm_add_feature(scm_s_system);
#endif
#ifdef vms
  scm_add_feature(s_ed);
#endif
}

