/* Scheme In One Defun, but in C this time.
 
 *                      COPYRIGHT (c) 1988-1994 BY                          *
 *        PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS.       *
 *			   ALL RIGHTS RESERVED                              *

Permission to use, copy, modify, distribute and sell this software
and its documentation for any purpose and without fee is hereby
granted, provided that the above copyright notice appear in all copies
and that both that copyright notice and this permission notice appear
in supporting documentation, and that the name of Paradigm Associates
Inc not be used in advertising or publicity pertaining to distribution
of the software without specific, written prior permission.

PARADIGM DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
PARADIGM BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
SOFTWARE.

*/

/*

gjc@paradigm.com, gjc@mitech.com

Paradigm Associates Inc          Phone: 617-492-6079
29 Putnam Ave, Suite 6
Cambridge, MA 02138


   Release 1.0: 24-APR-88
   Release 1.1: 25-APR-88, added: macros, predicates, load. With additions by
    Barak.Pearlmutter@DOGHEN.BOLTZ.CS.CMU.EDU: Full flonum recognizer,
    cleaned up uses of NULL/0. Now distributed with siod.scm.
   Release 1.2: 28-APR-88, name changes as requested by JAR@AI.AI.MIT.EDU,
    plus some bug fixes.
   Release 1.3: 1-MAY-88, changed env to use frames instead of alist.
    define now works properly. vms specific function edit.
   Release 1.4 20-NOV-89. Minor Cleanup and remodularization.
    Now in 3 files, siod.h, slib.c, siod.c. Makes it easier to write your
    own main loops. Some short-int changes for lightspeed C included.
   Release 1.5 29-NOV-89. Added startup flag -g, select stop and copy
    or mark-and-sweep garbage collection, which assumes that the stack/register
    marking code is correct for your architecture. 
   Release 2.0 1-DEC-89. Added repl_hooks, Catch, Throw. This is significantly
    different enough (from 1.3) now that I'm calling it a major release.
   Release 2.1 4-DEC-89. Small reader features, dot, backquote, comma.
   Release 2.2 5-DEC-89. gc,read,print,eval, hooks for user defined datatypes.
   Release 2.3 6-DEC-89. save_forms, obarray intern mechanism. comment char.
   Release 2.3a......... minor speed-ups. i/o interrupt considerations.
   Release 2.4 27-APR-90 gen_readr, for read-from-string.
   Release 2.5 18-SEP-90 arrays added to SIOD.C by popular demand. inums.
   Release 2.6 11-MAR-92 function prototypes, some remodularization.
   Release 2.7 20-MAR-92 hash tables, fasload. Stack check.
   Release 2.8  3-APR-92 Bug fixes, \n syntax in string reading.
   Release 2.9 28-AUG-92 gc sweep bug fix. fseek, ftell, etc. Change to
    envlookup to allow (a . rest) suggested by bowles@is.s.u-tokyo.ac.jp.
   Release 2.9a 10-AUG-93. Minor changes for Windows NT.
   Release 3.0  12-JAN-94. Release it, include changes/cleanup recommended by
    andreasg@nynexst.com for the OS2 C++ compiler. Compilation and running
    tested using DEC C, VAX C. WINDOWS NT. GNU C on SPARC.

   Festival changes (awb@cstr.ed.ac.uk)
   Note there have been substantial changes to this from its original
   form which may have introduced bugs.  Please contact Alan W Black
   (awb@cstr.ed.ac.uk) first if you find problems unless you can confirm
   they also exist in the original siod-3.0 release

  */

#include <stdio.h>
#include <string.h>
#include <ctype.h>
#include <signal.h>
#include <math.h>
#include <stdlib.h>
#include <time.h>
#include "EST_unix.h"

#include "EST_cutils.h"
#include "siod.h"
#include "siodp.h"
#include "io.h"

#include "EST_Pathname.h"
#include "EST_error.h"

static void check_first_line(FILE *lf);
static int restricted_function_call(LISP l);
static int f_getc(FILE *f);
static void f_ungetc(int c, FILE *f);

char *siod_version(void)
{return("3.0 FIELD TEST");}

LISP heap_1,heap_2;
LISP heap,heap_end,heap_org;
long heap_size = DEFAULT_HEAP_SIZE;
long old_heap_used;
long which_heap;
long gc_status_flag = 0;
long show_backtrace = 0;
char *init_file = (char *) NULL;
char *tkbuffer = NULL;
long gc_kind_copying = 0;
long gc_cells_allocated = 0;
double gc_time_taken;
LISP *stack_start_ptr;
LISP freelist;

long nointerrupt = 1;
long interrupt_differed = 0;
LISP oblistvar = NIL;
LISP current_env = NIL;
LISP backtrace = NIL;
LISP restricted = NIL;
LISP truth = NIL;
LISP eof_val = NIL;
LISP sym_errobj = NIL;
LISP sym_progn = NIL;
LISP sym_lambda = NIL;
LISP sym_quote = NIL;
LISP sym_dot = NIL;
LISP open_files = NIL;
LISP unbound_marker = NIL;
LISP *obarray;
long obarray_dim = 100;
struct catch_frame *catch_framep = (struct catch_frame *) NULL;
void (*repl_puts)(char *) = NULL;
LISP (*repl_read)(void) = NULL;
LISP (*repl_eval)(LISP) = NULL;
void (*repl_print)(LISP) = NULL;
repl_getc_fn siod_fancy_getc = f_getc;
repl_ungetc_fn siod_fancy_ungetc = f_ungetc;
LISP *inums;
LISP siod_docstrings = NIL;  /* for builtin functions */
long inums_dim = 100;
struct user_type_hooks *user_types = NULL;
struct gc_protected *protected_registers = NULL;
jmp_buf save_regs_gc_mark;
double gc_rt;
long gc_cells_collected;
char *user_ch_readm = "";
char *user_te_readm = "";
LISP (*user_readm)(int, struct gen_readio *) = NULL;
LISP (*user_readt)(char *,long, int *) = NULL;
void (*fatal_exit_hook)(void) = NULL;
#ifdef THINK_C
int ipoll_counter = 0;
#endif
static FILE *fwarn=NULL;
int siod_interactive = 1;

int rl_pos = -1;  // actually used by readline 
char *repl_prompt = "siod>";
char *siod_prog_name = "";
char *siod_primary_prompt = "siod> ";
char *siod_secondary_prompt = "> ";

// A list of objects with gc_free_once set in their user_type_hooks structure
// whose gc_free function has been called in the current GC sweep.
void **dead_pointers = NULL;	
int size_dead_pointers = 0;
int num_dead_pointers = 0;
#define DEAD_POINTER_GROWTH (10)

static LISP set_restricted(LISP l);

char *stack_limit_ptr = NULL;
long stack_size = 
#ifdef THINK_C
  10000;
#else
  500000;
#endif

static void start_rememberring_dead(void)
{
  num_dead_pointers=0;
}

static int is_dead(void *ptr)
{
  int i;
  for(i=0; i<num_dead_pointers; i++)
    if (dead_pointers[i] == ptr)
      return 1;
  return 0;
}

static void mark_as_dead(void *ptr)
{
  int i;
  if (num_dead_pointers == size_dead_pointers)
      dead_pointers = wrealloc(dead_pointers, void *, size_dead_pointers += DEAD_POINTER_GROWTH);

  for(i=0; i<num_dead_pointers; i++)
    if (dead_pointers[i] == ptr)
      return;

  dead_pointers[num_dead_pointers++] = ptr;
}

void process_cla(int argc,char **argv,int warnflag)
{int k;
 for(k=1;k<argc;++k)
   {if (strlen(argv[k])<2) continue;
    if (argv[k][0] != '-')
      {if (warnflag) printf("bad arg: %s\n",argv[k]);continue;}
    switch(argv[k][1])
      {case 'h':
	 heap_size = atol(&(argv[k][2]));
	 break;
       case 'o':
	 obarray_dim = atol(&(argv[k][2]));
	 break;
       case 'i':
	 init_file = &(argv[k][2]);
	 break;
       case 'n':
	 inums_dim = atol(&(argv[k][2]));
	 break;
       case 'g':
	 gc_kind_copying = atol(&(argv[k][2]));
	 break;
       case 's':
	 stack_size = atol(&(argv[k][2]));
	 break;
       default:
	 if (warnflag) printf("bad arg: %s\n",argv[k]);}}}

void print_welcome(void)
{printf("Welcome to SIOD, Scheme In One Defun, Version %s\n",
	siod_version());
 printf("(C) Copyright 1988-1994 Paradigm Associates Inc.\n");}

void print_hs_1(void)
{printf("heap_size = %ld cells, %ld bytes. %ld inums. GC is %s\n",
        heap_size,heap_size*sizeof(struct obj),
	inums_dim,
	(gc_kind_copying == 1) ? "stop and copy" : "mark and sweep");}

void print_hs_2(void)
{if (gc_kind_copying == 1)
   printf("heap_1 at %p, heap_2 at %p\n",heap_1,heap_2);
 else
   printf("heap_1 at %p\n",heap_1);}

long no_interrupt(long n)
{long x;
 x = nointerrupt;
 nointerrupt = n;
 if ((nointerrupt == 0) && (interrupt_differed == 1))
   {interrupt_differed = 0;
    err_ctrl_c();}
 return(x);}

void handle_sigfpe(int sig SIG_restargs)
{(void)sig;
 signal(SIGFPE,handle_sigfpe);
 err("floating point exception",NIL);}

void handle_sigint(int sig SIG_restargs)
{(void)sig;
 signal(SIGINT,handle_sigint);
 /* Solaris seems to need a relse before it works again */
#ifdef __svr4__
 sigrelse(SIGINT);
#endif
 if (nointerrupt == 1)
   interrupt_differed = 1;
 else
   err_ctrl_c();}

/* I don't have a clean way to do this but need to reset this if */
/* ctrl-c occurs. */
int audsp_mode = FALSE;

void err_ctrl_c(void)
{   
    audsp_mode = FALSE;
    rl_pos = -1;
    err("control-c interrupt",NIL);}

LISP get_eof_val(void)
{return(eof_val);}

void siod_reset_prompt(void)
{ 
  repl_prompt = siod_primary_prompt;
}

long repl_driver(long want_sigint,long want_init,struct repl_hooks *h)
{int k;
 struct repl_hooks hd;
 LISP stack_start;
 stack_start_ptr = &stack_start;
 stack_limit_ptr = STACK_LIMIT(stack_start_ptr,stack_size);
 est_errjmp = walloc(jmp_buf,1);
 k = setjmp(*est_errjmp);
 if(k) 
 {
     sock_acknowledge_error();  /* if there is a client let them know */
     siod_reset_prompt();
 }
 if (k == 2) return(2);
 if (want_sigint) signal(SIGINT,handle_sigint);
 signal(SIGFPE,handle_sigfpe);
 close_open_files();
 catch_framep = (struct catch_frame *) NULL;
 errjmp_ok = 1;
 interrupt_differed = 0;
 nointerrupt = 0;
 if (want_init && init_file && (k == 0)) vload(init_file,0);
 // Can't see where else to put this
 if ((siod_interactive) && (!isatty(0)))
 {   //  readline (or its replacement) would do this if stdin was a terminal
     fprintf(stdout,"%s",repl_prompt);
     fflush(stdout);
 }
 if (!h)
   {hd.repl_puts = repl_puts;
    hd.repl_read = repl_read;
    hd.repl_eval = repl_eval;
    hd.repl_print = repl_print;
    return(repl(&hd));}
 else
   return(repl(h));}

static void ignore_puts(char *st)
{(void)st;}

static void noprompt_puts(char *st)
{if (strcmp(st,"> ") != 0)
   put_st(st);}

static char *repl_c_string_arg = NULL;
static long repl_c_string_flag = 0;

static LISP repl_c_string_read(void)
{LISP s;
 if (repl_c_string_arg == NULL)
   return(get_eof_val());
 s = strcons(strlen(repl_c_string_arg),repl_c_string_arg);
 repl_c_string_arg = NULL;
 return(read_from_lstring(s));}

static void ignore_print(LISP x)
{(void)x;
 repl_c_string_flag = 1;}

static void not_ignore_print(LISP x)
{repl_c_string_flag = 1;
 lprint(x);}

long repl_c_string(char *str,
		   long want_sigint,long want_init,long want_print)
{struct repl_hooks h;
 long retval;
 if (want_print)
   h.repl_puts = noprompt_puts;
 else
   h.repl_puts = ignore_puts;
 h.repl_read = repl_c_string_read;
 h.repl_eval = NULL;
 if (want_print)
   h.repl_print = not_ignore_print;
 else
   h.repl_print = ignore_print;
 repl_c_string_arg = str;
 repl_c_string_flag = 0;
 retval = repl_driver(want_sigint,want_init,&h);
 if (retval != 0)
   return(retval);
 else if (repl_c_string_flag == 1)
   return(0);
 else
   return(2);}

#ifdef unix
#include <sys/types.h>
#include <sys/times.h>
double myruntime(void)
{double total;
 struct tms b;
 times(&b);
 total = b.tms_utime;
 total += b.tms_stime;
 return(total / 60.0);}
#else
#if defined(THINK_C) | defined(WIN32) | defined(VMS)
#ifndef CLOCKS_PER_SEC
#define CLOCKS_PER_SEC CLK_TCK
#endif
double myruntime(void)
{return(((double) clock()) / ((double) CLOCKS_PER_SEC));}
#else
double myruntime(void)
{time_t x;
 time(&x);
 return((double) x);}
#endif
#endif

void set_repl_hooks(void (*puts_f)(char *),
		    LISP (*read_f)(void),
		    LISP (*eval_f)(LISP),
		    void (*print_f)(LISP))
{repl_puts = puts_f;
 repl_read = read_f;
 repl_eval = eval_f;
 repl_print = print_f;}

void fput_st(FILE *f,const char *st)
{long flag;
 if (f != NULL)  /* so we can block warning messages easily */
 {
     flag = no_interrupt(1);
     fprintf(f,"%s",st);
     no_interrupt(flag);
 }
}

void put_st(const char *st)
{fput_st(stdout,st);}
     
void grepl_puts(char *st,void (*repl_putss)(char *))
{if (repl_putss == NULL)
   {fput_st(fwarn,st);
    if (fwarn != NULL) fflush(stdout);}
 else
   (*repl_putss)(st);}

static void display_backtrace(LISP args)
{
    /* Display backtrace information */
    LISP l;
    int i;
    int local_show_backtrace = show_backtrace;
    show_backtrace = 0;  // so we don't recurse if an error occurs

    if (cdr(args) == NIL)
    {
	printf("BACKTRACE:\n");
	for (i=0,l=backtrace; l != NIL; l=cdr(l),i++)
	{
	    fprintf(stdout,"%4d: ",i);
	    pprintf(stdout,car(l),3,72,2,2);
	    fprintf(stdout,"\n");
	}
    }
    else if (FLONUMP(car(cdr(args))))
    {
	printf("BACKTRACE:\n");
	int nth = (int)FLONM(car(cdr(args)));
	LISP frame = siod_nth(nth,backtrace);
	fprintf(stdout,"%4d: ",nth);
	pprintf(stdout,frame,3,72,-1,-1);
	fprintf(stdout,"\n");
    }

    show_backtrace = local_show_backtrace;
}
     
long repl(struct repl_hooks *h)
{LISP x,cw = 0;
 double rt;
 gc_kind_copying = 0;
 while(1)
   {
#if 0
    if ((gc_kind_copying == 1) && ((gc_status_flag) || heap >= heap_end))
     {rt = myruntime();
      gc_stop_and_copy();
      sprintf(tkbuffer,
	      "GC took %g seconds, %ld compressed to %ld, %ld free\n",
	      myruntime()-rt,old_heap_used,
	      (long)(heap-heap_org),(long)(heap_end-heap));
      grepl_puts(tkbuffer,h->repl_puts);}
    /* grepl_puts("> ",h->repl_puts); */
#endif
    if (h->repl_read == NULL)
      x = lread();
    else
      x = (*h->repl_read)();
    if EQ(x,eof_val) break;
    rt = myruntime();
    if (gc_kind_copying == 1)
      cw = heap;
    else
      {gc_cells_allocated = 0;
       gc_time_taken = 0.0;}
    /* Check if its a debugger command */
    if ((TYPE(x) == tc_cons) && 
	(TYPE(car(x)) == tc_symbol) &&
	(streq(":backtrace",get_c_string(car(x)))))
    {
	display_backtrace(x);
	x = NIL;
    }
    else if ((restricted != NIL) &&
	     (restricted_function_call(x) == FALSE))
	err("Expression contains functions not in restricted list",x);
    else
    {
	backtrace = NIL;  /* reset backtrace info */
	if (h->repl_eval == NULL)
	    x = leval(x,NIL);
	else
	    x = (*h->repl_eval)(x);
    }
    if (gc_kind_copying == 1)
      sprintf(tkbuffer,
	      "Evaluation took %g seconds %ld cons work\n",
	      myruntime()-rt,
	      (long)(heap-cw));
    else
      sprintf(tkbuffer,
	      "Evaluation took %g seconds (%g in gc) %ld cons work\n",
	      myruntime()-rt,
	      gc_time_taken,
	      gc_cells_allocated);
    grepl_puts(tkbuffer,h->repl_puts);
    setvar(rintern("!"),x,NIL);  /* save value in var called '!' */
    if (h->repl_print == NULL)
    {
	if (siod_interactive)
	    pprint(x);               /* pretty print the result */
    }
    else
      (*h->repl_print)(x);}
 return(0);}

void set_fatal_exit_hook(void (*fcn)(void))
{fatal_exit_hook = fcn;}

static LISP err(const char *message, LISP x, const char *s)
{
    nointerrupt = 1;
    if NNULLP(x) 
    {
	fprintf(stderr,"SIOD ERROR: %s %s\n",
		(message) ? message : "?",
		(s) ?s : ""
		);
	lprin1f(x,stderr);
	fprintf(stderr,"\n");
	fflush(stderr);
    }
    else
    {
	fprintf(stderr,"SIOD ERROR: %s %s\n",
		(message) ? message : "?",
		(s) ?s : ""
		);
	fflush(stderr);
    }

    if (show_backtrace == 1)
	display_backtrace(NIL);
    
    if (errjmp_ok == 1) {setvar(sym_errobj,x,NIL); longjmp(*est_errjmp,1);}
    close_open_files();  /* can give clue to where error is */
    fprintf(stderr,"%s: fatal error exiting.\n",siod_prog_name);
    if (fatal_exit_hook)
	(*fatal_exit_hook)();
    else
	exit(1);
    return(NIL);
}

LISP err(const char *message, LISP x)
{
  return err(message, x, NULL);
}

LISP err(const char *message, const char *x)
{
  return err(message, NULL, x);
}

LISP errswitch(void)
{return(err("BUG. Reached impossible case",NIL));}

void err_stack(char *ptr)
     /* The user could be given an option to continue here */
{(void)ptr;
 err("the currently assigned stack limit has been exceded",NIL);}

LISP stack_limit(LISP amount,LISP silent)
{if NNULLP(amount)
   {stack_size = get_c_int(amount);
    stack_limit_ptr = STACK_LIMIT(stack_start_ptr,stack_size);}
 if NULLP(silent)
   {sprintf(tkbuffer,"Stack_size = %ld bytes, [%p,%p]\n",
	    stack_size,stack_start_ptr,stack_limit_ptr);
    put_st(tkbuffer);
    return(NIL);}
 else
   return(flocons(stack_size));}

char *get_c_string(LISP x)
{
 if (NULLP(x))
     return "nil";
 else if TYPEP(x,tc_symbol)
   return(PNAME(x));
 else if TYPEP(x,tc_flonum)
 {
     if (FLONMPNAME(x) == NULL)
     {
	 char b[TKBUFFERN];
	 sprintf(b,"%g",FLONM(x));
	 FLONMPNAME(x) = (char *)must_malloc(strlen(b)+1);
	 sprintf(FLONMPNAME(x),"%s",b);
     }
     return FLONMPNAME(x);
 }
 else if TYPEP(x,tc_string)
   return(x->storage_as.string.data);
 else
   err("not a symbol or string",x);
 return(NULL);}

LISP lerr(LISP message, LISP x)
{err(get_c_string(message),x);
 return(NIL);}

void gc_fatal_error(void)
{err("ran out of storage",NIL);}

LISP newcell(long type)
{LISP z;
 NEWCELL(z,type);
 return(z);}

LISP cons(LISP x,LISP y)
{LISP z;
 NEWCELL(z,tc_cons);
 CAR(z) = x;
 CDR(z) = y;
 return(z);}

LISP string_cell(const char *s, int len)
{
  LISP z;
  NEWCELL(z,tc_string);
  char *b = walloc(char, len+1);
  memcpy(b, s, len);
  b[len]='\0';
  z->storage_as.string.data = b;
  z->storage_as.string.dim=len;

  return(z);
}

LISP atomp(LISP x)
{
    if ((x==NIL) || CONSP(x)) 
	return NIL; 
    else 
	return truth;
}

LISP consp(LISP x)
{if CONSP(x) return(truth); else return(NIL);}

LISP car(LISP x)
{switch TYPE(x)
   {case tc_nil:
      return(NIL);
    case tc_cons:
      return(CAR(x));
    default:
      return(err("wta to car",x));}}

LISP cdr(LISP x)
{switch TYPE(x)
   {case tc_nil:
      return(NIL);
    case tc_cons:
      return(CDR(x));
    default:
      return(err("wta to cdr",x));}}

LISP setcar(LISP cell, LISP value)
{if NCONSP(cell) err("wta to setcar",cell);
 return(CAR(cell) = value);}

LISP setcdr(LISP cell, LISP value)
{if NCONSP(cell) err("wta to setcdr",cell);
 return(CDR(cell) = value);}

LISP flocons(double x)
{LISP z;
 long n=0;
 if ((inums_dim > 0) &&
     ((x - (n = (long)x)) == 0) &&
     (x >= 0) &&
     (n < inums_dim))
   return(inums[n]);
 NEWCELL(z,tc_flonum);
 FLONMPNAME(z) = NULL;
 FLONM(z) = x;
 return(z);}

LISP numberp(LISP x)
{if FLONUMP(x) return(truth); else return(NIL);}

LISP plus(LISP args)
{
    LISP l;
    double sum;
    for (sum=0.0,l=args; l != NIL; l=cdr(l))
    {
	if (NFLONUMP(car(l))) err("wta to plus",car(l));
	sum += FLONM(car(l));
    }
    return flocons(sum);
}

LISP ltimes(LISP args)
{
    LISP l;
    double product;
    for (product=1.0,l=args; l != NIL; l=cdr(l))
    {
	if (NFLONUMP(car(l))) err("wta to times",car(l));
	product *= FLONM(car(l));
    }
    return flocons(product);
}

LISP ltimes(LISP x,LISP y)
{if NFLONUMP(x) err("wta(1st) to times",x);
 if NFLONUMP(y) err("wta(2nd) to times",y);
 return(flocons(FLONM(x)*FLONM(y)));}

LISP difference(LISP x,LISP y)
{if NFLONUMP(x) err("wta(1st) to difference",x);
 if NFLONUMP(y) err("wta(2nd) to difference",y);
 return(flocons(FLONM(x) - FLONM(y)));}

LISP quotient(LISP x,LISP y)
{if NFLONUMP(x) err("wta(1st) to quotient",x);
 if NFLONUMP(y) err("wta(2nd) to quotient",y);
 return(flocons(FLONM(x)/FLONM(y)));}

LISP greaterp(LISP x,LISP y)
{if NFLONUMP(x) err("wta(1st) to greaterp",x);
 if NFLONUMP(y) err("wta(2nd) to greaterp",y);
 if (FLONM(x)>FLONM(y)) return(truth);
 return(NIL);}

LISP lessp(LISP x,LISP y)
{if NFLONUMP(x) err("wta(1st) to lessp",x);
 if NFLONUMP(y) err("wta(2nd) to lessp",y);
 if (FLONM(x)<FLONM(y)) return(truth);
 return(NIL);}

LISP eq(LISP x,LISP y)
{if EQ(x,y) return(truth); else return(NIL);}

LISP eql(LISP x,LISP y)
{if EQ(x,y) return(truth); else 
 if NFLONUMP(x) return(NIL); else
 if NFLONUMP(y) return(NIL); else
 if (FLONM(x) == FLONM(y)) return(truth);
 return(NIL);}

LISP symcons(char *pname,LISP vcell)
{LISP z;
 NEWCELL(z,tc_symbol);
 PNAME(z) = pname;
 VCELL(z) = vcell;
 return(z);}

LISP symbolp(LISP x)
{if SYMBOLP(x) return(truth); else return(NIL);}

LISP symbol_boundp(LISP x,LISP env)
{LISP tmp;
 if NSYMBOLP(x) err("not a symbol",x);
 tmp = envlookup(x,env);
 if NNULLP(tmp) return(truth);
 if EQ(VCELL(x),unbound_marker) return(NIL); else return(truth);}

LISP symbol_value(LISP x,LISP env)
{LISP tmp;
 if NSYMBOLP(x) err("not a symbol",x);
 tmp = envlookup(x,env);
 if NNULLP(tmp) return(CAR(tmp));
 tmp = VCELL(x);
 if EQ(tmp,unbound_marker) err("unbound variable",x);
 return(tmp);}

LISP symbol_value_p(LISP x,LISP env,int *set)
{LISP tmp;
 *set = 1;
 if NSYMBOLP(x) err("not a symbol",x);
 tmp = envlookup(x,env);
 if NNULLP(tmp) return(CAR(tmp));
 tmp = VCELL(x);
 if EQ(tmp,unbound_marker) {*set = 0; return NIL;}
 return(tmp);}

char *must_malloc(unsigned long size)
{char *tmp;
 tmp = walloc(char,size);
 if (tmp == (char *)NULL) err("failed to allocate storage from system",NIL);
 return(tmp);}

LISP gen_intern(char *name,int require_copy)
{LISP l,sym,sl;
 const unsigned char *cname;
 long hash=0,n,c,flag;
 flag = no_interrupt(1);
 if (name == NULL)
     return NIL;
 else if (obarray_dim > 1)
   {hash = 0;
    n = obarray_dim;
    cname = (unsigned char *)name;
    while((c = *cname++)) hash = ((hash * 17) ^ c) % n;
    sl = obarray[hash];}
 else
   sl = oblistvar;
 for(l=sl;NNULLP(l);l=CDR(l))
   if (strcmp(name,PNAME(CAR(l))) == 0)
     {no_interrupt(flag);
      return(CAR(l));}
 /* Need a new symbol */
 if (require_copy)
     sym = symcons(wstrdup(name),unbound_marker);
 else
     sym = symcons(name,unbound_marker);
 if (obarray_dim > 1) obarray[hash] = cons(sym,sl);
 oblistvar = cons(sym,oblistvar);
 no_interrupt(flag);
 return(sym);}

LISP cintern(char *name)
{return(gen_intern(name,FALSE));}

LISP rintern(const char *name)
{
    if (name == 0)
	return NIL;
    char *dname = (char *)(void *)name;
    return gen_intern(dname,TRUE);
}

LISP intern(LISP name)
{return(rintern(get_c_string(name)));}

LISP subrcons(long type, char *name, SUBR_FUNC f)
{LISP z;
 NEWCELL(z,type);
 (*z).storage_as.subr.name = name;
 (*z).storage_as.subr0.f = f;
 return(z);}

LISP closure(LISP env,LISP code)
{LISP z;
 NEWCELL(z,tc_closure);
 (*z).storage_as.closure.env = env;
 (*z).storage_as.closure.code = code;
 return(z);}

void gc_unprotect(LISP *location)
{
    /* allow LISP values in a location top be gc'ed again */
    struct gc_protected *reg,*l;
    for(l=0,reg = protected_registers; reg; reg = reg->next)
    {
	if (reg->location == location)
	    break;
	l = reg;
    }
    if (reg == 0)
    {
	fprintf(stderr,"Cannot unprotected %lx: never protected\n",
		(unsigned long)*location);
	fflush(stderr);
    }
    else if (l==0) /* its the first one in the list that needs to be deleted */
    {
	reg = protected_registers;
	protected_registers = reg->next;
	wfree(reg);
    }
    else
    {
	reg = l->next;
	l->next = reg->next;
	wfree(reg);
    }

    return;
}

void gc_protect(LISP *location)
{
    struct gc_protected *reg;
    for(reg = protected_registers; reg; reg = reg->next)
    {
	if (reg->location == location)
	    return;   // already protected
    }
    // not protected so add it
    gc_protect_n(location,1);
}

void gc_protect_n(LISP *location,long n)
{struct gc_protected *reg;
 reg = (struct gc_protected *) must_malloc(sizeof(struct gc_protected));
 (*reg).location = location;
 (*reg).length = n;
 (*reg).next = protected_registers;
  protected_registers = reg;}

void gc_protect_sym(LISP *location,char *st)
{*location = cintern(st);
 gc_protect(location);}

void scan_registers(void)
{struct gc_protected *reg;
 LISP *location;
 long j,n;
 for(reg = protected_registers; reg; reg = (*reg).next)
   {location = (*reg).location;
    n = (*reg).length;
    for(j=0;j<n;++j)
      location[j] = gc_relocate(location[j]);}}

void init_storage(int init_heap_size)
{long j;
 init_storage_1(init_heap_size);
 init_storage_a();
 set_gc_hooks(tc_c_file,FALSE,NULL,NULL,NULL,file_gc_free,NULL,&j);
 set_print_hooks(tc_c_file,file_prin1, NULL);
 LISP stack_start;
 stack_start_ptr = &stack_start;
 stack_limit_ptr = STACK_LIMIT(stack_start_ptr,stack_size);
}

void init_storage_1(int init_heap_size)
{LISP ptr,next,end;
 long j;
 tkbuffer = (char *) must_malloc(TKBUFFERN+1);
 heap_1 = (LISP) must_malloc(sizeof(struct obj)*init_heap_size);
 heap = heap_1;
 which_heap = 1;
 heap_org = heap;
 heap_end = heap + init_heap_size;
 if (gc_kind_copying == 1)
   heap_2 = (LISP) must_malloc(sizeof(struct obj)*init_heap_size);
 else
   {ptr = heap_org;
    end = heap_end;
    while(1)
      {(*ptr).type = tc_free_cell;
       next = ptr + 1;
       if (next < end)
	 {CDR(ptr) = next;
	  ptr = next;}
       else
	 {CDR(ptr) = NIL;
	  break;}}
    freelist = heap_org;}
 gc_protect(&oblistvar);
 gc_protect(&backtrace);
 gc_protect(&current_env);
 if (obarray_dim > 1)
   {obarray = (LISP *) must_malloc(sizeof(LISP) * obarray_dim);
    for(j=0;j<obarray_dim;++j)
      obarray[j] = NIL;
    gc_protect_n(obarray,obarray_dim);}
 unbound_marker = cons(cintern("**unbound-marker**"),NIL);
 gc_protect(&unbound_marker);
 eof_val = cons(cintern("eof"),NIL);
 gc_protect(&eof_val);
 gc_protect(&siod_docstrings);
 gc_protect_sym(&truth,"t");
 setvar(truth,truth,NIL);
 setvar(cintern("nil"),NIL,NIL);
 setvar(cintern("let"),cintern("let-internal-macro"),NIL);
 setvar(cintern("stderr"),
	fd_to_scheme_file(fileno(stderr),"stderr","w",FALSE),NIL);
 gc_protect_sym(&sym_errobj,"errobj");
 setvar(sym_errobj,NIL,NIL);
 gc_protect_sym(&sym_progn,"begin");
 gc_protect_sym(&sym_lambda,"lambda");
 gc_protect_sym(&sym_quote,"quote");
 gc_protect_sym(&sym_dot,".");
 gc_protect(&open_files);
 if (inums_dim > 0)
   {inums = (LISP *) must_malloc(sizeof(LISP) * inums_dim);
    for(j=0;j<inums_dim;++j)
      {NEWCELL(ptr,tc_flonum);
       FLONM(ptr) = j;
       FLONMPNAME(ptr) = NULL;
       inums[j] = ptr;}
    gc_protect_n(inums,inums_dim);}}
 
void init_subr(char *name, long type, SUBR_FUNC fcn)
{setvar(cintern(name),subrcons(type,name,fcn),NIL);}
void init_subr(char *name, long type, SUBR_FUNC fcn,char *doc)
{LISP lname = cintern(name);
 setvar(lname,subrcons(type,name,fcn),NIL);
 setdoc(lname,cstrcons(doc));}

/* New versions requiring documentation strings */
void init_subr_0(char *name, LISP (*fcn)(void),char *doc)
{init_subr(name,tc_subr_0,(SUBR_FUNC)fcn,doc);}
void init_subr_1(char *name, LISP (*fcn)(LISP),char *doc)
{init_subr(name,tc_subr_1,(SUBR_FUNC)fcn,doc);}
void init_subr_2(char *name, LISP (*fcn)(LISP,LISP),char *doc)
{init_subr(name,tc_subr_2,(SUBR_FUNC)fcn,doc);}
void init_subr_3(char *name, LISP (*fcn)(LISP,LISP,LISP),char *doc)
{init_subr(name,tc_subr_3,(SUBR_FUNC)fcn,doc);}
void init_subr_4(char *name, LISP (*fcn)(LISP,LISP,LISP,LISP),char *doc)
{init_subr(name,tc_subr_4,(SUBR_FUNC)fcn,doc);}
void init_lsubr(char *name, LISP (*fcn)(LISP),char *doc)
{init_subr(name,tc_lsubr,(SUBR_FUNC)fcn,doc);}
void init_fsubr(char *name, LISP (*fcn)(LISP,LISP),char *doc)
{init_subr(name,tc_fsubr,(SUBR_FUNC)fcn,doc);}
void init_msubr(char *name, LISP (*fcn)(LISP *,LISP *),char *doc)
{init_subr(name,tc_msubr,(SUBR_FUNC)fcn,doc);}

void setdoc(LISP name,LISP doc)
{
    /* Set documentation string for name */
    LISP lpair = assq(name,siod_docstrings);
    if (lpair == NIL)
	siod_docstrings = cons(cons(name,doc),siod_docstrings);
    else
    {
	cerr << "SIOD: duplicate builtin function: " <<
	    get_c_string(name) << endl;
	cerr << "SIOD: probably an error" << endl;
	CDR(lpair) = doc;
    }
}

LISP assq(LISP x,LISP alist)
{LISP l,tmp;
 for(l=alist;CONSP(l);l=CDR(l))
   {tmp = CAR(l);
    if (CONSP(tmp) && EQ(CAR(tmp),x)) return(tmp);
    INTERRUPT_CHECK();}
 if EQ(l,NIL) return(NIL);
 return(err("improper list to assq",alist));}

struct user_type_hooks *get_user_type_hooks(long type)
{long n;
 if (user_types == NULL)
   {n = sizeof(struct user_type_hooks) * tc_table_dim;
    user_types = (struct user_type_hooks *) must_malloc(n);
    memset(user_types,0,n);}
 if ((type >= 0) && (type < tc_table_dim))
   return(&user_types[type]);
 else
   err("type number out of range",NIL);
 return(NULL);}
 
int siod_register_user_type(const char *name)
{
    // Register a new object type for LISP
    static int siod_user_type = tc_first_user_type;
    int new_type = siod_user_type;
    struct user_type_hooks *th;

    if (new_type == tc_table_dim)
    {
	cerr << "SIOD: no more new types allowed, tc_table_dim needs increased"
	    << endl;
	return tc_table_dim-1;
    }
    else
	siod_user_type++;

    th=get_user_type_hooks(new_type);
    th->name = wstrdup(name);
    return new_type;
}

void set_gc_hooks(long type,
		  int gc_free_once,
		  LISP (*rel)(LISP),
		  LISP (*mark)(LISP),
		  void (*scan)(LISP),
		  void (*free)(LISP),
		  void (*clear)(LISP),
		  long *kind)
{struct user_type_hooks *p;
 p = get_user_type_hooks(type);
 p->gc_free_once = gc_free_once;
 p->gc_relocate = rel;
 p->gc_scan = scan;
 p->gc_mark = mark;
 p->gc_free = free;
 p->gc_clear = clear;
 *kind = gc_kind_copying;}

LISP gc_relocate(LISP x)
{LISP nw;
 struct user_type_hooks *p;
 if EQ(x,NIL) return(NIL);
 if ((*x).gc_mark == 1) return(CAR(x));
 switch TYPE(x)
   {case tc_flonum:
       if (FLONMPNAME(x) != NULL)
	   wfree(FLONMPNAME(x));    /* free the print name */
       FLONMPNAME(x) = NULL;
    case tc_cons:
    case tc_symbol:
    case tc_closure:
    case tc_subr_0:
    case tc_subr_1:
    case tc_subr_2:
    case tc_subr_3:
    case tc_subr_4:
    case tc_lsubr:
    case tc_fsubr:
    case tc_msubr:
      if ((nw = heap) >= heap_end) gc_fatal_error();
      heap = nw+1;
      memcpy(nw,x,sizeof(struct obj));
      break;
    default:
      p = get_user_type_hooks(TYPE(x));
      if (p->gc_relocate)
	nw = (*p->gc_relocate)(x);
      else
	{if ((nw = heap) >= heap_end) gc_fatal_error();
	 heap = nw+1;
	 memcpy(nw,x,sizeof(struct obj));}}
 (*x).gc_mark = 1;
 CAR(x) = nw;
 return(nw);}

LISP get_newspace(void)
{LISP newspace;
 if (which_heap == 1)
   {newspace = heap_2;
    which_heap = 2;}
 else
   {newspace = heap_1;
    which_heap = 1;}
 heap = newspace;
 heap_org = heap;
 heap_end = heap + heap_size;
 return(newspace);}

void scan_newspace(LISP newspace)
{LISP ptr;
 struct user_type_hooks *p;
 for(ptr=newspace; ptr < heap; ++ptr)
   {switch TYPE(ptr)
      {case tc_cons:
       case tc_closure:
	 CAR(ptr) = gc_relocate(CAR(ptr));
	 CDR(ptr) = gc_relocate(CDR(ptr));
	 break;
       case tc_symbol:
	 VCELL(ptr) = gc_relocate(VCELL(ptr));
	 break;
       case tc_flonum:
       case tc_subr_0:
       case tc_subr_1:
       case tc_subr_2:
       case tc_subr_3:
       case tc_subr_4:
       case tc_lsubr:
       case tc_fsubr:
       case tc_msubr:
	 break;
       default:
	 p = get_user_type_hooks(TYPE(ptr));
	 if (p->gc_scan) (*p->gc_scan)(ptr);}}}

void free_oldspace(LISP space,LISP end)
{LISP ptr;
 struct user_type_hooks *p;
 for(ptr=space; ptr < end; ++ptr)
   if (ptr->gc_mark == 0)
     switch TYPE(ptr)
       {case tc_cons:
	case tc_closure:
	case tc_symbol:
	   break;
	case tc_flonum:
	   if (FLONMPNAME(ptr) != NULL)
	       wfree(FLONMPNAME(ptr));    /* free the print name */
	   FLONMPNAME(ptr) = NULL;
	   break;
        case tc_string:
          wfree(ptr->storage_as.string.data);
	  break;
	case tc_subr_0:
	case tc_subr_1:
	case tc_subr_2:
	case tc_subr_3:
	case tc_subr_4:
	case tc_lsubr:
	case tc_fsubr:
	case tc_msubr:
	  break;
	default:
	  p = get_user_type_hooks(TYPE(ptr));
	  if (p->gc_free) 
	    (*p->gc_free)(ptr);
       }
}
      
void gc_stop_and_copy(void)
{LISP newspace,oldspace,end;
 long flag;
 int ej_ok;
 flag = no_interrupt(1);
 fprintf(stderr,"GC ing \n");
 ej_ok = errjmp_ok;
 errjmp_ok = 0;
 oldspace = heap_org;
 end = heap;
 old_heap_used = end - oldspace;
 newspace = get_newspace();
 scan_registers();
 scan_newspace(newspace);
 free_oldspace(oldspace,end);
 errjmp_ok = ej_ok;
 no_interrupt(flag);}

void gc_for_newcell(void)
{long flag;
 int ej_ok;
/* if (errjmp_ok == 0) gc_fatal_error(); */
 flag = no_interrupt(1);
 ej_ok = errjmp_ok;
 errjmp_ok = 0;
 gc_mark_and_sweep();
 errjmp_ok = ej_ok;
 no_interrupt(flag);
 if NULLP(freelist) gc_fatal_error();}

void gc_mark_and_sweep(void)
{LISP stack_end;
 gc_ms_stats_start();
 setjmp(save_regs_gc_mark);
 mark_locations((LISP *) save_regs_gc_mark,
		(LISP *) (((char *) save_regs_gc_mark) + sizeof(save_regs_gc_mark)));
 mark_protected_registers();
 mark_locations((LISP *) stack_start_ptr,
		(LISP *) &stack_end);
#ifdef THINK_C
 mark_locations((LISP *) ((char *) stack_start_ptr + 2),
		(LISP *) ((char *) &stack_end + 2));
#endif
 gc_sweep();
 gc_ms_stats_end();}

void gc_ms_stats_start(void)
{gc_rt = myruntime();
 gc_cells_collected = 0;
 if (gc_status_flag)
     fprintf(stderr,"[starting GC]\n");}

void gc_ms_stats_end(void)
{gc_rt = myruntime() - gc_rt;
 gc_time_taken = gc_time_taken + gc_rt;
 if (gc_status_flag)
     fprintf(stderr,"[GC took %g cpu seconds, %ld cells collected]\n",
	     gc_rt,
	     gc_cells_collected);}

void gc_mark(LISP ptr)
{struct user_type_hooks *p;

 gc_mark_loop:
 if NULLP(ptr) return;
 if ((*ptr).gc_mark) return;
 (*ptr).gc_mark = 1;
 switch ((*ptr).type)
   {case tc_flonum:
      break;
    case tc_cons:
      gc_mark(CAR(ptr));
      ptr = CDR(ptr);
      goto gc_mark_loop;
    case tc_symbol:
      ptr = VCELL(ptr);
      goto gc_mark_loop;
    case tc_closure:
      gc_mark((*ptr).storage_as.closure.code);
      ptr = (*ptr).storage_as.closure.env;
      goto gc_mark_loop;
    case tc_subr_0:
    case tc_subr_1:
    case tc_subr_2:
    case tc_subr_3:
    case tc_subr_4:
      break;
    case tc_string:
      break;
    case tc_lsubr:
    case tc_fsubr:
    case tc_msubr:
      break;
    default:
      p = get_user_type_hooks(TYPE(ptr));
      if (p->gc_mark)
	ptr = (*p->gc_mark)(ptr);}}

void mark_protected_registers(void)
{struct gc_protected *reg;
 LISP *location;
 long j,n;
 for(reg = protected_registers; reg; reg = (*reg).next)
 {
     location = (*reg).location;
     n = (*reg).length; 
     for(j=0;j<n;++j)
	 gc_mark(location[j]);}}

void mark_locations(LISP *start,LISP *end)
{LISP *tmp;
 long n;
 if (start > end)
   {tmp = start;
    start = end;
    end = tmp;}
 n = end - start;
 mark_locations_array(start,n);}

void mark_locations_array(LISP *x,long n)
{int j;
 LISP p;
 for(j=0;j<n;++j)
   {p = x[j];
    if ((p >= heap_org) &&
	(p < heap_end) &&
	(((((char *)p) - ((char *)heap_org)) % sizeof(struct obj)) == 0) &&
	NTYPEP(p,tc_free_cell))
      gc_mark(p);}}

void gc_sweep(void)
{LISP ptr,end,nfreelist;
 long n;
 struct user_type_hooks *p;
 end = heap_end;
 n = 0;
 nfreelist = NIL;
 start_rememberring_dead();
 for(ptr=heap_org; ptr < end; ++ptr)
   if (((*ptr).gc_mark == 0))
     {switch((*ptr).type)
	{case tc_flonum:
	    if (FLONMPNAME(ptr) != NULL)
		wfree(FLONMPNAME(ptr));    /* free the print name */
	    FLONMPNAME(ptr) = NULL;
	    break;
         case tc_string:
	    wfree(ptr->storage_as.string.data);
	    break;
	 case tc_free_cell:
	 case tc_cons:
	 case tc_closure:
	 case tc_symbol:
	 case tc_subr_0:
	 case tc_subr_1:
	 case tc_subr_2:
	 case tc_subr_3:
	 case tc_subr_4:
	 case tc_lsubr:
	 case tc_fsubr:
	 case tc_msubr:
	   break;
	 default:
	   p = get_user_type_hooks(TYPE(ptr));
	   if (p->gc_free)
	     {
	     if (p->gc_free_once)
	       {
		 if (!is_dead(USERVAL(ptr)))
		   {
		     (*p->gc_free)(ptr);
		     mark_as_dead(USERVAL(ptr));
		   }
	       }
	     else
	       (*p->gc_free)(ptr);
	     }
	}
      ++n;
      (*ptr).type = tc_free_cell;
      CDR(ptr) = nfreelist;
      nfreelist = ptr;
     }
   else
     {
     (*ptr).gc_mark = 0;
     p = get_user_type_hooks(TYPE(ptr));
     if (p->gc_clear)
       (*p->gc_clear)(ptr);
     }
 gc_cells_collected = n;
 freelist = nfreelist;
}

LISP user_gc(LISP args)
{long old_status_flag,flag;
 int ej_ok;
 if (gc_kind_copying == 1)
   err("implementation cannot GC at will with stop-and-copy\n",
       NIL);
 flag = no_interrupt(1);
 ej_ok = errjmp_ok;
 errjmp_ok = 0;
 old_status_flag = gc_status_flag;
 if NNULLP(args)
   if NULLP(car(args)) gc_status_flag = 0; else gc_status_flag = 1;
 gc_mark_and_sweep();
 gc_status_flag = old_status_flag;
 errjmp_ok = ej_ok;
 no_interrupt(flag);
 return(NIL);}

LISP set_backtrace(LISP n)
{
  if (n)
      show_backtrace = 1;
  else
      show_backtrace = 0;
  return n;
}
      
LISP gc_status(LISP args)
{LISP l;
 int n;
 if NNULLP(args) 
   if NULLP(car(args)) gc_status_flag = 0; else gc_status_flag = 1;
 if (gc_kind_copying == 1)
   {if (gc_status_flag)
      fput_st(fwarn,"garbage collection is on\n");
   else
     fput_st(fwarn,"garbage collection is off\n");
    sprintf(tkbuffer,"%ld allocated %ld free\n",
	    (long)(heap - heap_org),(long)(heap_end - heap));
    fput_st(fwarn,tkbuffer);}
 else
   {if (gc_status_flag)
      fput_st(fwarn,"garbage collection verbose\n");
    else
      fput_st(fwarn,"garbage collection silent\n");
    {for(n=0,l=freelist;NNULLP(l); ++n) l = CDR(l);
     sprintf(tkbuffer,"%ld allocated %ld free\n",
	     (long)((heap_end - heap_org) - n),(long)n);
     fput_st(fwarn,tkbuffer);}}
 return(NIL);}

LISP leval_args(LISP l,LISP env)
{LISP result,v1,v2,tmp;
 if NULLP(l) return(NIL);
 if NCONSP(l) err("bad syntax argument list",l);
 result = cons(leval(CAR(l),env),NIL);
 for(v1=result,v2=CDR(l);
     CONSP(v2);
     v1 = tmp, v2 = CDR(v2))
  {tmp = cons(leval(CAR(v2),env),NIL);
   CDR(v1) = tmp;}
 if NNULLP(v2) err("bad syntax argument list",l);
 return(result);}

LISP extend_env(LISP actuals,LISP formals,LISP env)
{if SYMBOLP(formals)
   return(cons(cons(cons(formals,NIL),cons(actuals,NIL)),env));
 return(cons(cons(formals,actuals),env));}

#define ENVLOOKUP_TRICK 1

LISP envlookup(LISP var,LISP env)
{LISP frame,al,fl,tmp;
 for(frame=env;CONSP(frame);frame=CDR(frame))
   {tmp = CAR(frame);
    if NCONSP(tmp) err("damaged frame",tmp);
    for(fl=CAR(tmp),al=CDR(tmp);CONSP(fl);fl=CDR(fl),al=CDR(al))
      {if NCONSP(al) err("too few arguments",tmp);
       if EQ(CAR(fl),var) return(al);}
    /* suggested by a user. It works for reference (although conses)
       but doesn't allow for set! to work properly... */
#if (ENVLOOKUP_TRICK)
    if (SYMBOLP(fl) && EQ(fl, var)) return(cons(al, NIL));
#endif
  }
 if NNULLP(frame) err("damaged env",env);
 return(NIL);}

void set_eval_hooks(long type,LISP (*fcn)(LISP, LISP *,LISP *))
{struct user_type_hooks *p;
 p = get_user_type_hooks(type);
 p->leval = fcn;}

LISP leval(LISP x,LISP env)
{LISP tmp,arg1,rval;
 struct user_type_hooks *p;
 STACK_CHECK(&x);
 backtrace = cons(x,backtrace);
 loop:
 INTERRUPT_CHECK();
 current_env = env;
 switch TYPE(x)
   {case tc_symbol:
      tmp = envlookup(x,env);
      if NNULLP(tmp) 
      {
	  backtrace = cdr(backtrace);
	  return(CAR(tmp));
      }
      tmp = VCELL(x);
      if EQ(tmp,unbound_marker) err("unbound variable",x);
      backtrace = cdr(backtrace);
      return tmp;
    case tc_cons:
      tmp = CAR(x);
      switch TYPE(tmp)
	{case tc_symbol:
	   tmp = envlookup(tmp,env);
	   if NNULLP(tmp)
	     {tmp = CAR(tmp);
	      break;}
	   tmp = VCELL(CAR(x));
	   if EQ(tmp,unbound_marker) err("unbound variable",CAR(x));
	   break;
	 case tc_cons:
	   tmp = leval(tmp,env);
	   break;}
      switch TYPE(tmp)
	{case tc_subr_0:
	    rval = SUBR0(tmp)();
	    backtrace = cdr(backtrace);
	    return rval;
	 case tc_subr_1:
	    rval = SUBR1(tmp)(leval(car(CDR(x)),env)); 
	    backtrace = cdr(backtrace);
	    return rval;
	 case tc_subr_2:
	    x = CDR(x);
	    arg1 = leval(car(x),env);
	    x = NULLP(x) ? NIL : CDR(x);
	    rval = SUBR2(tmp)(arg1,leval(car(x),env));
	    backtrace = cdr(backtrace);
	    return rval;
	 case tc_subr_3:
	    x = CDR(x);
	    arg1 = leval(car(x),env);
	    x = NULLP(x) ? NIL : CDR(x);
	    rval = SUBR3(tmp)(arg1,leval(car(x),env),leval(car(cdr(x)),env));
	    backtrace = cdr(backtrace);
	    return rval;
	 case tc_subr_4:
	    x = CDR(x);
	    arg1 = leval(car(x),env);
	    x = NULLP(x) ? NIL : CDR(x);
	    rval = SUBR4(tmp)(arg1,leval(car(x),env),
			      leval(car(cdr(x)),env),
			      leval(car(cdr(cdr(x))),env));
	    backtrace = cdr(backtrace);
	    return rval;
	 case tc_lsubr:
	    rval = SUBR1(tmp)(leval_args(CDR(x),env));
	    backtrace = cdr(backtrace);
	    return rval;
	 case tc_fsubr:
	    rval = SUBR2(tmp)(CDR(x),env);
	    backtrace = cdr(backtrace);
	    return rval;
	 case tc_msubr:
	   if NULLP(SUBRM(tmp)(&x,&env)) 
	   {
	       backtrace = cdr(backtrace);
	       return(x);
	   }
	   goto loop;
	 case tc_closure:
	   env = extend_env(leval_args(CDR(x),env),
			    car((*tmp).storage_as.closure.code),
			    (*tmp).storage_as.closure.env);
	   x = cdr((*tmp).storage_as.closure.code);
	   goto loop;
	 case tc_symbol:
	   x = cons(tmp,cons(cons(sym_quote,cons(x,NIL)),NIL));
	   x = leval(x,NIL);
	   goto loop;
	 default:
	   p = get_user_type_hooks(TYPE(tmp));
	   if (p->leval)
	     {if NULLP((*p->leval)(tmp,&x,&env)) 
	      {
		  backtrace = cdr(backtrace);
		  return(x); 
	      }
	     else 
		 goto loop;}
	   err("bad function",tmp);}
    default:
      backtrace = cdr(backtrace);
      return(x);}}

LISP setvar(LISP var,LISP val,LISP env)
{LISP tmp;
 if NSYMBOLP(var) err("wta(non-symbol) to setvar",var);
 tmp = envlookup(var,env);
 if NULLP(tmp) return(VCELL(var) = val);
 return(CAR(tmp)=val);}
 
LISP leval_setq(LISP args,LISP env)
{return(setvar(car(args),leval(car(cdr(args)),env),env));}

LISP syntax_define(LISP args)
{if SYMBOLP(car(args)) return(args);
 return(syntax_define(
        cons(car(car(args)),
	cons(cons(sym_lambda,
	     cons(cdr(car(args)),
		  cdr(args))),
	     NIL))));}
      
LISP leval_define(LISP args,LISP env)
{LISP tmp,var,val;
 tmp = syntax_define(args);
 var = car(tmp);
 if NSYMBOLP(var) err("wta(non-symbol) to define",var);
 val = leval(car(cdr(tmp)),env);
 tmp = envlookup(var,env);
 if NNULLP(tmp) return(CAR(tmp) = val);
 if NULLP(env) return(VCELL(var) = val);
 tmp = car(env);
 setcar(tmp,cons(var,car(tmp)));
 setcdr(tmp,cons(val,cdr(tmp)));
 return(val);}
 
LISP leval_if(LISP *pform,LISP *penv)
{LISP args,env;
 args = cdr(*pform);
 env = *penv;
 if NNULLP(leval(car(args),env)) 
    *pform = car(cdr(args)); else *pform = car(cdr(cdr(args)));
 return(truth);}

LISP leval_lambda(LISP args,LISP env)
{LISP body;
 if NULLP(cdr(cdr(args)))
   body = car(cdr(args));
  else body = cons(sym_progn,cdr(args));
 return(closure(env,cons(arglchk(car(args)),body)));}
                         
LISP leval_progn(LISP *pform,LISP *penv)
{LISP env,l,next;
 env = *penv;
 l = cdr(*pform);
 next = cdr(l);
 while(NNULLP(next)) {leval(car(l),env);l=next;next=cdr(next);}
 *pform = car(l); 
 return(truth);}

LISP leval_or(LISP *pform,LISP *penv)
{LISP env,l,next,val;
 env = *penv;
 l = cdr(*pform);
 next = cdr(l);
 while(NNULLP(next))
   {val = leval(car(l),env);
    if NNULLP(val) {*pform = val; return(NIL);}
    l=next;next=cdr(next);}
 *pform = car(l); 
 return(truth);}

LISP leval_and(LISP *pform,LISP *penv)
{LISP env,l,next;
 env = *penv;
 l = cdr(*pform);
 if NULLP(l) {*pform = truth; return(NIL);}
 next = cdr(l);
 while(NNULLP(next))
   {if NULLP(leval(car(l),env)) {*pform = NIL; return(NIL);}
    l=next;next=cdr(next);}
 *pform = car(l); 
 return(truth);}

LISP leval_catch(LISP args,LISP env)
{struct catch_frame frame;
 int k;
 LISP l;
 volatile LISP val = NIL;
 frame.tag = leval(car(args),env);
 frame.next = catch_framep;
 k = setjmp(frame.cframe);
 catch_framep = &frame;
 if (k == 2)
   {catch_framep = frame.next;
    return(frame.retval);}
 for(l=cdr(args); NNULLP(l); l = cdr(l))
   val = leval(car(l),env);
 catch_framep = frame.next;
 return(val);}

LISP lthrow(LISP tag,LISP value)
{struct catch_frame *l;
 for(l=catch_framep; l; l = (*l).next)
   if EQ((*l).tag,tag)
     {(*l).retval = value;
      longjmp((*l).cframe,2);}
 err("no *catch found with this tag",tag);
 return(NIL);}

LISP leval_let(LISP *pform,LISP *penv)
{LISP env,l;
 l = cdr(*pform);
 env = *penv;
 *penv = extend_env(leval_args(car(cdr(l)),env),car(l),env);
 *pform = car(cdr(cdr(l)));
 return(truth);}

LISP reverse(LISP l)
{LISP n,p;
 n = NIL;
 for(p=l;NNULLP(p);p=cdr(p)) n = cons(car(p),n);
 return(n);}

LISP l_append(LISP l1, LISP l2)
{LISP n=l2,p,rl1 = reverse(l1);
 for(p=rl1;NNULLP(p);p=cdr(p)) 
     n = cons(car(p),n);
 return(n);}

LISP let_macro(LISP form)
{LISP p,fl,al,tmp;
 fl = NIL;
 al = NIL;
 for(p=car(cdr(form));NNULLP(p);p=cdr(p))
  {tmp = car(p);
   if SYMBOLP(tmp) {fl = cons(tmp,fl); al = cons(NIL,al);}
   else {fl = cons(car(tmp),fl); al = cons(car(cdr(tmp)),al);}}
 p = cdr(cdr(form));
 if NULLP(cdr(p)) p = car(p); else p = cons(sym_progn,p);
 setcdr(form,cons(reverse(fl),cons(reverse(al),cons(p,NIL))));
 setcar(form,cintern("let-internal"));
 return(form);}
   
LISP leval_quote(LISP args,LISP env)
{(void)env;
 return(car(args));}

LISP leval_tenv(LISP args,LISP env)
{(void)args;
 return(env);}

LISP leval_while(LISP args,LISP env)
{LISP l;
 while NNULLP(leval(car(args),env))
   for(l=cdr(args);NNULLP(l);l=cdr(l))
     leval(car(l),env);
 return(NIL);}

LISP symbolconc(LISP args)
{long size;
 LISP l,s;
 size = 0;
 tkbuffer[0] = 0;
 for(l=args;NNULLP(l);l=cdr(l))
   {s = car(l);
    if NSYMBOLP(s) err("wta(non-symbol) to symbolconc",s);
    size = size + strlen(PNAME(s));
    if (size >  TKBUFFERN) err("symbolconc buffer overflow",NIL);
    strcat(tkbuffer,PNAME(s));}
 return(rintern(tkbuffer));}

LISP symbolexplode(LISP name)
{
    LISP e=NIL;
    char *pname = get_c_string(name);
    char tt[2];
    int i;

    tt[1]='\0';

    for (i=0; pname[i] != '\0'; i++)
    {
	tt[0] = pname[i];
	e = cons(rintern(tt),e);
    }
    return reverse(e);
}

void set_print_hooks(long type,
		     void (*prin1)(LISP, FILE *),
		     void (*print_string)(LISP, char *)
		     )
{struct user_type_hooks *p;
 p = get_user_type_hooks(type);
 p->prin1 = prin1;
 p->print_string = print_string;
}

void set_io_hooks(long type,
		  LISP (*fast_print)(LISP,LISP),
		  LISP (*fast_read)(int,LISP))

{struct user_type_hooks *p;
 p = get_user_type_hooks(type);
 p->fast_print = fast_print;
 p->fast_read = fast_read;
}

void set_type_hooks(long type,
		    long (*c_sxhash)(LISP,long),
		    LISP (*equal)(LISP,LISP))


{struct user_type_hooks *p;
 p = get_user_type_hooks(type);
 p->c_sxhash = c_sxhash;
 p->equal = equal;
}

LISP lprin1f(LISP exp,FILE *f)
{LISP tmp;
 struct user_type_hooks *p;
 STACK_CHECK(&exp);
 INTERRUPT_CHECK();
 switch TYPE(exp)
   {case tc_nil:
      fput_st(f,"nil");
      break;
   case tc_cons:
      fput_st(f,"(");
      lprin1f(car(exp),f);
      for(tmp=cdr(exp);CONSP(tmp);tmp=cdr(tmp))
	{fput_st(f," ");lprin1f(car(tmp),f);}
      if NNULLP(tmp) {fput_st(f," . ");lprin1f(tmp,f);}
      fput_st(f,")");
      break;
    case tc_flonum:
      if (FLONMPNAME(exp) == NULL)
      {
	  sprintf(tkbuffer,"%g",FLONM(exp));
	  FLONMPNAME(exp) = (char *)must_malloc(strlen(tkbuffer)+1);
	  sprintf(FLONMPNAME(exp),"%s",tkbuffer);
      }
      sprintf(tkbuffer,"%s",FLONMPNAME(exp));
      fput_st(f,tkbuffer);
      break;
    case tc_symbol:
      fput_st(f,PNAME(exp));
      break;
    case tc_subr_0:
    case tc_subr_1:
    case tc_subr_2:
    case tc_subr_3:
    case tc_subr_4:
    case tc_lsubr:
    case tc_fsubr:
    case tc_msubr:
      sprintf(tkbuffer,"#<SUBR(%d) ",TYPE(exp));
      fput_st(f,tkbuffer);
      fput_st(f,(*exp).storage_as.subr.name);
      fput_st(f,">");
      break;
    case tc_closure:
      fput_st(f,"#<CLOSURE ");
      lprin1f(car((*exp).storage_as.closure.code),f);
      fput_st(f," ");
      lprin1f(cdr((*exp).storage_as.closure.code),f);
      fput_st(f,">");
      break;
    default:
      p = get_user_type_hooks(TYPE(exp));
      if (p->prin1)
	(*p->prin1)(exp,f);
      else 
      {
	  if (p->name) 
	      sprintf(tkbuffer,"#<%s %p>",p->name,USERVAL(exp));
	  else
	      sprintf(tkbuffer,"#<UNKNOWN %d %p>",TYPE(exp),exp);
	  fput_st(f,tkbuffer);}}
 return(NIL);}

LISP lprintfp(LISP exp,LISP file)
{lprin1f(exp,get_c_file(file,stdout));
 return(NIL);}

LISP terpri(LISP file)
{fput_st(get_c_file(file,stdout),"\n");
 return(NIL);}

LISP lreadfp(LISP file)
{return lreadf(get_c_file(file,stdout));}

LISP lprint(LISP exp)
{lprin1f(exp,stdout);
 put_st("\n");
 return(NIL);}

LISP lread(void)
{return(lreadf(stdin));}

static int f_getc(FILE *f)
{long iflag,dflag;
 int c;
 iflag = no_interrupt(1);
 dflag = interrupt_differed;
 c = getc(f);
 if ((c == '\n') && (f == stdin) && (siod_interactive))
 {
     fprintf(stdout,"%s",repl_prompt);
     fflush(stdout);
 }
#ifdef VMS
 if ((dflag == 0) & interrupt_differed & (f == stdin))
   while((c != 0) & (c != EOF)) c = getc(f);
#endif
 no_interrupt(iflag);
 return(c);}

static void f_ungetc(int c, FILE *f)
{ungetc(c,f);}

int flush_ws(struct gen_readio *f,char *eoferr)
{int c,commentp;
 commentp = 0;
 while(1)
   {c = GETC_FCN(f);
    if (c == EOF) if (eoferr) err(eoferr,NIL); else return(c);
    if (commentp) {if (c == '\n') commentp = 0;}
    else if (c == ';') commentp = 1;
    else if (!isspace(c)) return(c);}}

LISP lreadf(FILE *f)
{struct gen_readio s;
 if ((f == stdin) && (isatty(0)))
 {   /* readline (if selected) stuff -- only works with a terminal */
     s.getc_fcn = (int (*)(char *))siod_fancy_getc;
     s.ungetc_fcn = (void (*)(int, char *))siod_fancy_ungetc;
     s.cb_argument = (char *) f;
 }
 else  /* normal stuff */
 {
     s.getc_fcn = (int (*)(char *))f_getc;
     s.ungetc_fcn = (void (*)(int, char *))f_ungetc;
     s.cb_argument = (char *) f;
 }
 return(readtl(&s));}

LISP readtl(struct gen_readio *f)
{int c;
 c = flush_ws(f,(char *)NULL);
 if (c == EOF) return(eof_val);
 UNGETC_FCN(c,f);
 return(lreadr(f));}

void set_read_hooks(char *all_set,char *end_set,
		    LISP (*fcn1)(int, struct gen_readio *),
		    LISP (*fcn2)(char *,long, int *))
{user_ch_readm = all_set;
 user_te_readm = end_set;
 user_readm = fcn1;
 user_readt = fcn2;}

LISP lreadr(struct gen_readio *f)
{int c,j;
 char *p, *last_prompt;
 LISP rval;
 STACK_CHECK(&f);
 p = tkbuffer;
 c = flush_ws(f,"end of file inside read");
 switch (c)
   {case '(':
       last_prompt = repl_prompt;
       repl_prompt = siod_secondary_prompt;
       rval = lreadparen(f);
       repl_prompt = last_prompt;
       return rval;
    case ')':
      err("unexpected close paren",NIL);
    case '\'':
      return(cons(sym_quote,cons(lreadr(f),NIL)));
    case '`':
      return(cons(cintern("+internal-backquote"),lreadr(f)));
    case ',':
      c = GETC_FCN(f);
      switch(c)
	{case '@':
	   p = "+internal-comma-atsign";
	   break;
	 case '.':
	   p = "+internal-comma-dot";
	   break;
	 default:
	   p = "+internal-comma";
	   UNGETC_FCN(c,f);}
      return(cons(cintern(p),lreadr(f)));
    case '"':
       last_prompt = repl_prompt;
       repl_prompt = siod_secondary_prompt;
       rval = lreadstring(f);
       repl_prompt = last_prompt;
       return rval;
    default:
      if ((user_readm != NULL) && strchr(user_ch_readm,c))
	return((*user_readm)(c,f));}
 *p++ = c;
 for(j = 1; j<TKBUFFERN; ++j)
   {c = GETC_FCN(f);
    if (c == EOF) return(lreadtk(j));
    if (isspace(c)) return(lreadtk(j));
    if (strchr("()'`,;\"",c) || strchr(user_te_readm,c))
      {UNGETC_FCN(c,f);return(lreadtk(j));}
    *p++ = c;}
 return(err("token larger than TKBUFFERN",NIL));}

#if 0
LISP lreadparen(struct gen_readio *f)
{int c;
 LISP tmp;
 c = flush_ws(f,"end of file inside list");
 if (c == ')') return(NIL);
 UNGETC_FCN(c,f);
 tmp = lreadr(f);
 if EQ(tmp,sym_dot)
   {tmp = lreadr(f);
    c = flush_ws(f,"end of file inside list");
    if (c != ')') err("missing close paren",NIL);
    return(tmp);}
 return(cons(tmp,lreadparen(f)));}
#endif

/* Iterative version of the above */
LISP lreadparen(struct gen_readio *f)
{
    int c;
    LISP tmp,l=NIL;
    LISP last=l;

    while ((c = flush_ws(f,"end of file inside list")) != ')')
    {
	UNGETC_FCN(c,f);
	tmp = lreadr(f);
	if EQ(tmp,sym_dot)
	{
	    tmp = lreadr(f);
	    c = flush_ws(f,"end of file inside list");
	    if (c != ')') err("missing close paren",NIL);
	    if (l == NIL) err("no car for dotted pair",NIL);
	    CDR(last) = tmp;
	    break;
	}
	if (l == NIL)
	{
	    l = cons(tmp,NIL);
	    last = l;
	}
	else
	{
	    CDR(last) = cons(tmp,NIL);
	    last = cdr(last);
	}
    }
    return l;
}

LISP lreadtk(long j)
{int flag;
 unsigned char *p;
 LISP tmp;
 int adigit;
 p = (unsigned char *)tkbuffer;
 p[j] = 0;
 if (user_readt != NULL)
   {tmp = (*user_readt)((char *)p,j,&flag);
    if (flag) return(tmp);}
 if (strcmp("nil",tkbuffer) == 0)
     return NIL;
 if (*p == '-') p+=1;
 adigit = 0;
 while((*p < 128) && (isdigit(*p))) {p+=1; adigit=1;}
 if (*p=='.')
   {p += 1;
    while((*p < 128) && (isdigit(*p))) {p+=1; adigit=1;}}
 if (!adigit) goto a_symbol;
 if (*p=='e')
   {p+=1;
    if (*p=='-'||*p=='+') p+=1;
    if ((!isdigit(*p) || (*p > 127))) goto a_symbol; else p+=1;
    while((*p < 128) && (isdigit(*p))) p+=1;}
 if (*p) goto a_symbol;
 return(flocons(atof(tkbuffer)));
 a_symbol:
 return(rintern(tkbuffer));}
      
LISP copy_list(LISP x)
{if NULLP(x) return(NIL);
 STACK_CHECK(&x);
 return(cons(car(x),copy_list(cdr(x))));}

LISP oblistfn(void)
{return(copy_list(oblistvar));}

void close_open_files_upto(LISP end)
{LISP l,p;
 for(l=open_files;((l!=end)&&(l!=NIL));l=cdr(l))
   {p = car(l);
    if (p->storage_as.c_file.f)
      {fprintf(stderr,"closing a file left open: %s\n",
	       (p->storage_as.c_file.name) ? p->storage_as.c_file.name : "");
       fflush(stderr);
       file_gc_free(p);}}
 open_files = l;}

void close_open_files(void)
{
    close_open_files_upto(NIL);
}

LISP fd_to_scheme_file(int fd, 
		       const char *name, 
		       const char *how,
		       int close_on_error)
{
  LISP sym;
  long flag;
  flag = no_interrupt(1);
  sym = newcell(tc_c_file);
  sym->storage_as.c_file.f = (FILE *)NULL;
  sym->storage_as.c_file.name = (char *)NULL;

  if (fd != fileno(stderr))
      open_files = cons(sym,open_files);
  sym->storage_as.c_file.name = (char *) must_malloc(strlen(name)+1);
  if (fd == fileno(stdin))
      sym->storage_as.c_file.f = stdin;
  else   if (fd == fileno(stdout))
      sym->storage_as.c_file.f = stdout;
  else   if (fd == fileno(stderr))
      sym->storage_as.c_file.f = stderr;
  else if (!(sym->storage_as.c_file.f = fdopen(fd ,how)))
    {
      if (close_on_error)
	close(fd);
      perror(name);
      put_st("\n");
      err("could not open file", name);
    }
  strcpy(sym->storage_as.c_file.name,name);
  no_interrupt(flag);
  return(sym);
}

LISP fopen_c(const char *name, const char *how)
{
  LISP sym;
  int fd;

  fd = fd_open_file(name, how);

  if (fd < 0)
    err("could not open file", name);

  sym = fd_to_scheme_file(fd, name, how, 1);

  return(sym);
}

LISP siod_fdopen_c(int fd, const char *name, char *how)
{
  return fd_to_scheme_file(fd, name, how, 0);
}

LISP fopen_l(LISP what,LISP how)
{
  const char *r_or_w = NULLP(how) ? "rb" : get_c_string(how);

  return fopen_l(what, r_or_w);

}

LISP fopen_l(LISP what, const char *r_or_w)
{
  int fd = -1;
  const char *filename = NULL;

  if (NULLP(what))
    {
      filename = "-";
      fd = fd_open_stdinout(r_or_w);
    }
  else if (SYMBOLP(what) || STRINGP(what))
    {
      fd = fd_open_file((filename = get_c_string(what)), r_or_w);
    }
  else if (LIST1P(what))
    {
      fd = fd_open_file((filename = get_c_string(CAR(what))), r_or_w);
    }
  else if (CONSP(what)  &&  !CONSP(CDR(what)))
    {
      filename = "[tcp connection]";
      fd = fd_open_url("tcp", 
		       get_c_string(CAR(what)),
		       get_c_string(CDR(what)),
		       NULL,
		       r_or_w);
    }
  else if (LIST4P(what))
    {
      filename = "[url]";
      fd = fd_open_url(get_c_string(CAR1(what)),
		       get_c_string(CAR2(what)),
		       get_c_string(CAR3(what)),
		       get_c_string(CAR4(what)),
		       r_or_w);
    }
  else
    err("not openable", what);

  if (fd<0)
    err("can't open", what);

  return fd_to_scheme_file(fd, filename, r_or_w, 1);
}

LISP delq(LISP elem,LISP l)
{if NULLP(l) return(l);
 STACK_CHECK(&elem);
 if EQ(elem,car(l)) return(cdr(l));
 setcdr(l,delq(elem,cdr(l)));
 return(l);}

LISP fflush_l(LISP p)
{
    if (p == NIL)
	fflush(stdout);
    else if NTYPEP(p,tc_c_file) 
	err("not a file",p);
    else
	fflush(p->storage_as.c_file.f);
    return NIL;
}

LISP fclose_l(LISP p)
{long flag;
 flag = no_interrupt(1);
 if NTYPEP(p,tc_c_file) err("not a file",p);
 file_gc_free(p);
 open_files = delq(p,open_files);
 no_interrupt(flag);
 return(NIL);}

LISP vload(const char *fname_raw, long cflag)
{
  LISP form,result,tail,lf;
 FILE *f;
  EST_Pathname fname(fname_raw);
 fput_st(fwarn,"loading ");
 fput_st(fwarn,fname);
 fput_st(fwarn,"\n");
 lf = fopen_c(fname,"rb");
 f = lf->storage_as.c_file.f;
 if (!cflag)
     check_first_line(f);
 result = NIL;
 tail = NIL;
 while(1)
   {form = lreadf(f);
    if EQ(form,eof_val) break;
    if (cflag)
      {form = cons(form,NIL);
       if NULLP(result)
	 result = tail = form;
       else
	 tail = setcdr(tail,form);}
    else
      leval(form,NIL);}
 fclose_l(lf);
 fput_st(fwarn,"done.\n");
 return(result);}

static void check_first_line(FILE *lf)
{  /* If this line starts #! skip it -- this is for scripts */
    int c0,c1,c2;
    if ((c0=getc(lf)) == '#')
    {
	if ((c1 = getc(lf)) == '!')
	    while (((c2=getc(lf)) != '\n') && (c2 != EOF)); /* skip to EOLN */
	else
	{
	    ungetc(c1,lf);
	    ungetc(c0,lf);  /* possibly somethings don't support 2 ungets */
	}
    }
    else
	ungetc(c0,lf);
}

LISP load(LISP fname,LISP cflag)
{return(vload(get_c_string(fname),NULLP(cflag) ? 0 : 1));}

LISP save_forms(LISP fname,LISP forms,LISP how)
{char *cname,*chow = NULL;
 LISP l,lf;
 FILE *f;
 cname = get_c_string(fname);
 if EQ(how,NIL) chow = "wb";
 else if EQ(how,cintern("a")) chow = "a";
 else err("bad argument to save-forms",how);
 fput_st(fwarn,(*chow == 'a') ? "appending" : "saving");
 fput_st(fwarn," forms to ");
 fput_st(fwarn,cname);
 fput_st(fwarn,"\n");
 lf = fopen_c(cname,chow);
 f = lf->storage_as.c_file.f;
 for(l=forms;NNULLP(l);l=cdr(l))
   {lprin1f(car(l),f);
    putc('\n',f);}
 fclose_l(lf);
 fput_st(fwarn,"done.\n");
 return(truth);}

LISP siod_quit(void)
{open_files = NIL;  // will be closed on exit with no warnings
 if (errjmp_ok) longjmp(*est_errjmp,2);
 else exit(0);
 return(NIL);}

LISP l_exit(LISP arg)
{
    if (arg == NIL)
	exit(0);
    else
	exit((int)FLONM(arg));

    // never happens
    return NULL;
}

LISP nullp(LISP x)
{if EQ(x,NIL) return(truth); else return(NIL);}

LISP arglchk(LISP x)
{
#if (!ENVLOOKUP_TRICK)
 LISP l;
 if SYMBOLP(x) return(x);
 for(l=x;CONSP(l);l=CDR(l));
 if NNULLP(l) err("improper formal argument list",x);
#endif
 return(x);}

void file_gc_free(LISP ptr)
{if ((ptr->storage_as.c_file.f) &&
     (ptr->storage_as.c_file.f != stdin) &&
     (ptr->storage_as.c_file.f != stdout))
   {fclose(ptr->storage_as.c_file.f);
    ptr->storage_as.c_file.f = (FILE *) NULL;}
 if (ptr->storage_as.c_file.name)
   {wfree(ptr->storage_as.c_file.name);
    ptr->storage_as.c_file.name = NULL;}}
   
void file_prin1(LISP ptr,FILE *f)
{char *name;
 name = ptr->storage_as.c_file.name;
 fput_st(f,"#<FILE ");
 sprintf(tkbuffer," %p",ptr->storage_as.c_file.f);
 fput_st(f,tkbuffer);
 if (name)
   {fput_st(f," ");
    fput_st(f,name);}
 fput_st(f,">");}

FILE *get_c_file(LISP p,FILE *deflt)
{if (NULLP(p) && deflt) return(deflt);
 if NTYPEP(p,tc_c_file) err("not a file",p);
 if (!p->storage_as.c_file.f) err("file is closed",p);
 return(p->storage_as.c_file.f);}

LISP lgetc(LISP p)
{int i;
 i = f_getc(get_c_file(p,stdin));
 return((i == EOF) ? NIL : flocons((double)i));}

LISP lputc(LISP c,LISP p)
{long flag;
 int i;
 FILE *f;
 f = get_c_file(p,stdout);
 if FLONUMP(c)
   i = (int)FLONM(c);
 else
   i = *get_c_string(c);
 flag = no_interrupt(1);
 putc(i,f);
 no_interrupt(flag);
 return(NIL);}
     
LISP lputs(LISP str,LISP p)
{fput_st(get_c_file(p,stdout),get_c_string(str));
 return(NIL);}

LISP lftell(LISP file)
{return(flocons((double)ftell(get_c_file(file,NULL))));}

LISP lfwarning(LISP mode)
{
    /* if mode is non-nil switch warnings on */
    if (mode == NIL)
	fwarn = NULL;
    else
	fwarn = stdout;
    return NIL;
}

LISP lfseek(LISP file,LISP offset,LISP direction)
{return((fseek(get_c_file(file,NULL),get_c_int(offset),get_c_int(direction)))
	? NIL : truth);}

LISP parse_number(LISP x)
{char *c;
 c = get_c_string(x);
 return(flocons(atof(c)));}

void init_subrs(void)
{init_subrs_1();
 init_subrs_a();}

LISP closure_code(LISP exp)
{return(exp->storage_as.closure.code);}

LISP closure_env(LISP exp)
{return(exp->storage_as.closure.env);}

LISP symbol_downcase(LISP symbol)
{
    char *symname = get_c_string(symbol);
    char *downsym = walloc(char,strlen(symname)+1);
    LISP newsym;
    int i;

    for (i=0; symname[i] != '\0'; i++)
	if (isupper(symname[i]))
	    downsym[i] = tolower(symname[i]);
	else
	    downsym[i] = symname[i];
    downsym[i] = '\0';
    newsym = strcons(strlen(downsym),downsym);
    wfree(downsym);
    
    return newsym;
}

LISP symbol_upcase(LISP symbol)
{
    char *symname = get_c_string(symbol);
    char *upsym = walloc(char,sizeof(symbol)+1);
    LISP newsym;
    int i;

    for (i=0; symname[i] != '\0'; i++)
	if (islower(symname[i]))
	    upsym[i] = toupper(symname[i]);
	else
	    upsym[i] = symname[i];
    upsym[i] = '\0';
    newsym = strcons(strlen(upsym),upsym);
    wfree(upsym);
    
    return newsym;
}

LISP directory_entries(LISP ldir, LISP lnoflagdir)
{
  LISP lentries=NIL;
  EST_Pathname dir(get_c_string(ldir));

  if (dir == "")
    return NIL;

  dir = dir.as_directory();

  EST_StrList entries(dir.entries(lnoflagdir!=NIL?0:1));
  EST_Litem *item;

  for(item=entries.head(); item; item = next(item))
    {
      EST_String entry(entries(item));
      if (entry != "../" && entry != "./" && entry != ".." && entry != ".")
	{
	  LISP litem = string_cell(entry, entry.length());
	  lentries = cons(litem, lentries);
	}
    }

  return lentries;
}

LISP path_is_dirname(LISP lpath)
{
  EST_Pathname path(get_c_string(lpath));

  return path.is_dirname()?lpath:NIL;
}

LISP path_is_filename(LISP lpath)
{
  EST_Pathname path(get_c_string(lpath));

  return path.is_filename()?lpath:NIL;
}

LISP path_as_directory(LISP lpath)
{
  EST_Pathname path(get_c_string(lpath));
  EST_Pathname res(path.as_directory());
  return string_cell(res, res.length());
}

LISP path_as_file(LISP lpath)
{
  EST_Pathname path(get_c_string(lpath));
  EST_Pathname res(path.as_file());

  return string_cell(res, res.length());
}

LISP path_append(LISP lpaths)
{
  if (CONSP(lpaths))
    {
      EST_Pathname res(get_c_string(car(lpaths)));
      lpaths = cdr(lpaths);
      while(lpaths != NIL)
	{
	  res = res +get_c_string(car(lpaths));
	  lpaths = cdr(lpaths);
	}
      return string_cell(res, res.length());
    }
  return NIL;
}

LISP path_basename(LISP lpath)
{
  EST_Pathname path(get_c_string(lpath));
  EST_Pathname res(path.basename(1));

  return string_cell(res, res.length());
}

LISP symbol_basename(LISP path, LISP suffix)
{
    //  Like UNIX basename
    char *pathstr = get_c_string(path);
    char *bname,*suff;
    int i, j, k, start, end;
    LISP newsym;

    if (suffix == NIL)
	suff = "";
    else
	suff = get_c_string(suffix);

    for (i=strlen(pathstr); i >= 0; i--)
	if (pathstr[i] == '/')
	    break;
    start = i+1;
    for (j=strlen(pathstr),k=strlen(suff); k >= 0; k--,j--)
	if (pathstr[j] != suff[k])
	    break;
    if (k != -1)
	end = strlen(pathstr);
    else
	end = j+1;

    bname = walloc(char,end-start+1);
    memcpy(bname,&pathstr[start],end-start);
    bname[end-start] = '\0';
    newsym = strcons(strlen(bname),bname);
    wfree(bname);
    
    return newsym;
}

LISP l_nint(LISP number)
{
    if (TYPEP(number,tc_flonum))
    {
	int iii = (int)(FLONM(number)+0.5);
	return flocons(iii);
    }
    else if (TYPEP(number,tc_symbol))
    {
	int iii = (int)(atof(get_c_string(number))+0.5);
	return flocons(iii);
    }
    else
	err("nint: argument not a number",number);

    return NIL;
}

LISP l_log(LISP n)
{
    if (n && (TYPEP(n,tc_flonum)))
	return flocons(log(FLONM(n)));
    else
	err("log: not a number",n);

    return NIL;
}

LISP l_rand()
{
    double r = (double)abs(rand())/(double)0x7fff;
    
    return flocons(r);
}

LISP l_exp(LISP n)
{
    if (n && (TYPEP(n,tc_flonum)))
	return flocons(exp(FLONM(n)));
    else
	err("exp: not a number",n);
    return NIL;
}

LISP l_sqrt(LISP n)
{
    if (n && (TYPEP(n,tc_flonum)))
	return flocons(sqrt(FLONM(n)));
    else
	err("sqrt: not a number",n);
    return NIL;
}

LISP l_pow(LISP x, LISP y)
{
    if (x && (TYPEP(x,tc_flonum)) &&
	y && (TYPEP(y,tc_flonum)))
	return flocons(pow(FLONM(x),FLONM(y)));
    else
	err("pow: x or y not a number",cons(x,cons(y,NIL)));
    return NIL;
}

LISP l_unwind_protect(LISP args, LISP env)
{
    // Do normal, if an error occurs do onerror
    jmp_buf * volatile local_errjmp = est_errjmp;
    est_errjmp = walloc(jmp_buf,1);
    volatile long local_errjmp_ok = errjmp_ok;
    errjmp_ok=1;   /* allow errjmps in here */
    volatile LISP r=NIL;
    volatile LISP previous_open_files = open_files;

    if (setjmp(*est_errjmp) != 0)
    {
	est_errjmp = local_errjmp;
	errjmp_ok = local_errjmp_ok;
	siod_reset_prompt();
	// Close any that were opened below here
	close_open_files_upto(previous_open_files);
	r = leval(car(cdr(args)),env);
    }
    else
    {
	r = leval(car(args),env);
	est_errjmp = local_errjmp;
	errjmp_ok = local_errjmp_ok;
    }

    return r;
}

void init_subrs_1a(void)
{
  init_subr_2("cons",cons,
 "(cons DATA1 DATA2)\n\
  Construct cons pair whose car is DATA1 and cdr is DATA2.");
 init_subr_1("car",car,
 "(car DATA1)\n\
  Returns car of DATA1.  If DATA1 is nil or a symbol, return nil.");
 init_subr_1("cdr",cdr,
 "(cdr DATA1)\n\
  Returns cdr of DATA1.  If DATA1 is nil or a symbol, return nil.");
 init_subr_2("set-car!",setcar,
 "(set-car! CONS1 DATA1)\n\
  Set car of CONS1 to be DATA1.  Returns CONS1. If CONS1 not of type\n\
  consp an error is is given.  This is a destructive operation.");
 init_subr_2("set-cdr!",setcdr,
 "(set-cdr! CONS1 DATA1)\n\
  Set cdr of CONS1 to be DATA1.  Returns CONS1. If CONS1 not of type\n\
  consp an error is is given.  This is a destructive operation.");
 init_lsubr("+",plus,
 "(+ NUM1 NUM2 ...)\n\
  Returns the sum of NUM1 and NUM2 ...  An error is given is any argument\n\
  is not a number.");
 init_subr_2("-",difference,
 "(- NUM1 NUM2)\n\
  Returns the difference between NUM1 and NUM2.  An error is given is any\n\
  argument is not a number.");
 init_lsubr("*",ltimes,
 "(* NUM1 NUM2 ...)\n\
  Returns the product of NUM1 and NUM2 ...  An error is given is any\n\
  argument is not a number.");
 init_subr_2("/",quotient,
 "(/ NUM1 NUM2)\n\
  Returns the quotient of NUM1 and NUM2.  An error is given is any\n\
  argument is not a number.");
 init_subr_2(">",greaterp,
 "(> NUM1 NUM2)\n\
  Returns t if NUM1 is greater than NUM2, nil otherwise.  An error is\n\
  given is either argument is not a number.");
 init_subr_2("<",lessp,
 "(< NUM1 NUM2)\n\
  Returns t if NUM1 is less than NUM2, nil otherwise.  An error is\n\
  given is either argument is not a number.");
 init_subr_2("eq?",eq,
 "(eq? DATA1 DATA2)\n\
  Returns t if DATA1 and DATA2 are the same object.");
 init_subr_2("eqv?",eql,
 "(eqv? DATA1 DATA2)\n\
  Returns t if DATA1 and DATA2 are the same object or equal numbers.");
}

void init_subrs_1b(void)
{
 init_subr_2("assq",assq,
 "(assq ITEM ALIST)\n\
  Returns pairs from ALIST whose car is ITEM or nil if ITEM is not in ALIST.");
 init_subr_2("delq",delq,
 "(delq ITEM LIST)\n\
  Destructively delete ITEM from LIST, returns LIST, if ITEM is not first\n\
  in LIST, cdr of LIST otherwise.  If ITEM is not in LIST, LIST is\n\
  returned unchanged." );
 init_subr_0("read",lread,
 "(read)\n\
  Read next s-expression from stdin and return it.");
 init_subr_0("eof-val",get_eof_val,
 "(eof_val)\n\
  Returns symbol used to indicate end of file.  May be used (with eq?)\n\
  to determine when end of file occurs while reading files.");
 init_subr_1("print",lprint,
 "(print DATA)\n\
  Print DATA to stdout if textual form.  Not a pretty printer.");
 init_subr_2("eval",leval,
 "(eval DATA)\n\
  Evaluate DATA and return result.");
 init_subr_2("printfp",lprintfp,
 "(printfp DATA FILEP)\n\
  Print DATA to file indicated by file pointer FILEP.  File pointers are\n\
  are created by fopen.");
 init_subr_1("readfp",lreadfp,
 "(readfp FILEP)\n\
  Read and return next s-expression from file indicated by file pointer\n\
  FILEP.  File pointers are created by fopen.");
 init_subr_1("terpri",terpri,
 "(terpri FILEP)\n\
  Print newline to FILEP, is FILEP is nil or not specified a newline it\n\
  is printed to stdout.");
 init_fsubr("define",leval_define,
 "(define (FUNCNAME ARG1 ARG2 ...) . BODY)\n\
 Define a new function call FUNCNAME with arguments ARG1, ARG2 ... and\n\
 BODY.");
 init_fsubr("lambda",leval_lambda,
 "(lambda (ARG1 ARG2 ...) . BODY)\n\
  Create closure (anonymous function) with arguments ARG1, ARG2 ... and \n\
 BODY.");
 init_msubr("if",leval_if,
 "(if COND TRUEPART FALSEPART)\n\
  If COND evaluates to non-nil evaluate TRUEPART and return result,\n\
  otherwise evaluate and return FALSEPART.  If COND is nil and FALSEPART\n\
  is nil, nil is returned.");
 init_fsubr("while",leval_while,
 "(while COND . BODY)\n\
  While COND evaluates to non-nil evaluate BODY.");
 init_msubr("begin",leval_progn,
 "(begin . BODY)\n\
  Evaluate s-expressions in BODY returning value of from last expression.");
 init_fsubr("set!",leval_setq,
 "(set! SYMBOL VAL)\n\
  Set SYMBOL to have value VAL, returns VAL.");
 init_msubr("or",leval_or,
 "(or DISJ1 DISJ2 ...)\n\
  Evaluate each disjunction DISJn in turn until one evaluates to non-nil.\n\
  Otherwise return nil.");
 init_msubr("and",leval_and,
 "(and CONJ1 CONJ2 ... CONJN)\n\
  Evaluate each conjunction CONJn in turn until one evaluates to nil.\n\
  Otherwise return value of CONJN.");
}

void init_subrs_1c(void)
{
 init_lsubr("format",l_format,
 "(format FD FORMATSTRING ARG0 ARG1 ...)\n\
  Output ARGs to FD using FROMATSTRING.  FORMATSTRING is like a printf\n\
  formatstrng.  FD may be a filedescriptor, or t (standard output) or\n\
  nil (return as a string).  Note not all printf format directive are\n\
  supported.  %l is additionally support for Lisp objects.\n\
  [see Scheme I/O]");
 init_fsubr("*catch",leval_catch,
 "(*catch TAG . BODY)\n\
  Evaluate BODY, if a *throw occurs with TAG then return value specified\n\
  by *throw.");
 init_subr_2("*throw",lthrow,
 "(*throw TAG VALUE)\n\
  Jump to *catch with TAG, causing *catch to return VALUE.");
 init_fsubr("quote",leval_quote,
 "(quote DATA)\n\
  Return data (unevaluated).");
 init_subr_0("oblist",oblistfn,
 "(oblist)\n\
  Return oblist.");
 init_subr_1("copy-list",copy_list,
 "(copy-list LIST)\n\
  Return new list with same members as LIST.");
 init_lsubr("gc-status",gc_status,
 "(gc-status OPTION)\n\
  Control summary information during garbage collection.  If OPTION is t,\n\
  output information at each garbage collection, if nil do gc silently.");
 init_lsubr("gc",user_gc,
 "(gc)\n\
  Collect garbage now, where gc method supports it.");
 init_subr_2("load",load,
 "(load FILENAME OPTION)\n\
  Load s-expressions in FILENAME.  If OPTION is nil or unspecified evaluate\n\
  each s-expression in FILENAME as it is read, if OPTION is t, return them\n\
  unevaluated in a list.");
 init_subr_1("pair?",consp,
 "(pair? DATA)\n\
  Returns t if DATA is a cons cell, nil otherwise.");
 init_subr_1("symbol?",symbolp,
 "(symbol? DATA)\n\
  Returns t if DATA is a symbol, nil otherwise.");
 init_subr_1("number?",numberp,
 "(number? DATA)\n\
  Returns t if DATA is a number, nil otherwise.");
 init_msubr("let-internal",leval_let,
 "(let-internal STUFF)\n\
  Internal function used to implement let.");
 init_subr_1("let-internal-macro",let_macro,
 "(let ((VAR1 VAL1) (VAR2 VAL2) ...) . BODY)\n\
  Evaluate BODY in an environment where VAR1 is set to VAL1, VAR2 is set\n\
  to VAL2 etc.");
 init_subr_2("symbol-bound?",symbol_boundp,
 "(symbol-bound? VARNAME)\n\
  Return t is VARNAME has a value, nil otherwise.");
 init_subr_2("symbol-value",symbol_value,
 "(symbol-value SYMBOLNAME)\n\
  Returns the value of SYMBOLNAME, an error is given SYMBOLNAME is not a\n\
  bound symbol.");
 init_subr_3("set-symbol-value!",setvar,
 "(set-symbol-value! SYMBOLNAME VALUE)\n\
  Set SYMBOLNAME's value to VALUE, this is much faster than set! but use\n\
  with caution.");
 init_fsubr("the-environment",leval_tenv,
 "(the-environment)\n\
  Returns the current (SIOD) environment.");
 init_subr_2("error",lerr,
 "(error MESSAGE DATA)\n\
  Prints MESSAGE about DATA and throws an error.");
 init_subr_0("quit",siod_quit,
 "(quit)\n\
  Exit from Festival, does not return.");
 init_subr_1("exit",l_exit,
 "(exit [RCODE])\n\
  Exit from Festival, if RCODE is given it is given as an argument to\n\
  the system call exit.");
 init_subr_1("not",nullp,
 "(not DATA)\n\
  Returns t if DATA is nil, nil otherwise.");
 init_subr_1("null?",nullp,
 "(null? DATA)\n\
  Returns t if DATA is nil, nil otherwise.");
 init_subr_2("env-lookup",envlookup,
 "(env-lookup VARNAME ENVIRONMENT)\n\
  Return value of VARNAME in ENVIRONMENT.");
 init_subr_1("reverse",reverse,
 "(reverse LIST)\n\
  Returns destructively reversed LIST.");
 init_lsubr("symbolconc",symbolconc,
 "(symbolconc SYMBOL1 SYMBOL2 ...)\n\
  Form new symbol by concatenation of the print forms of each of SYMBOL1\n\
  SYMBOL2 etc.");
 init_subr_1("symbolexplode",symbolexplode,
 "(symbolexplode SYMBOL)\n\
  Returns list of atoms one for each character in the print name of SYMBOL.");
 init_subr_3("save-forms",save_forms,
 "(save-forms FILENAME FORMS HOW)\n\
  Save FORMS in FILENAME.  If HOW is a appending FORMS to FILENAME,\n\
  or if HOW is w start from the beginning of FILENAME.");
}

void init_subrs_1d(void)
{
 init_subr_1("fflush",fflush_l,
 "(fflush FILEP)\n\
  Flush FILEP. If FILEP is nil, then flush stdout.");
 init_subr_2("fopen",fopen_l,
 "(fopen FILENAME HOW)\n\
  Return file pointer for FILENAME opened in mode HOW.");
 init_subr_1("fclose",fclose_l,
 "(fclose FILEP)\n\
  Close filepoint FILEP.");
 init_subr_1("getc",lgetc,
 "(getc FILEP)\n\
  Get next character from FILEP.  Character is returned as a number. If\n\
  FILEP is nil, or not specified input comes from stdin.");
 init_subr_2("putc",lputc,
 "(putc CHAR FILEP)\n\
  Put CHAR (a number) as a character to FILEP.  If FILEP is nil or not\n\
  specified output goes to stdout.");
 init_subr_2("puts",lputs,
 "(puts STRING FILEP)\n\
  Write STRING (print name of symbol) to FILEP.  If FILEP is nil or not\n\
  specified output goes to stdout.");
 init_subr_1("ftell",lftell,
 "(ftell FILEP)\n\
  Returns position in file FILEP is currently pointing at.");
 init_subr_3("fseek",lfseek,
 "(fseek FILEP OFFSET DIRECTION)\n\
  Position FILEP to OFFSET. If DIRECTION is 0 offset is from start of file.\n\
  If DIRECTION is 1, offset is from current position.  If DIRECTION is\n\
  2 offset is from end of file.");
 init_subr_1("fwarning",lfwarning,
 "(fwarning MODE)\n\
  For controlling various Festival warning messages.  If MODE is nil, or\n\
  not specified stop all warning messages from being displayed.  If MODE\n\
  display warning messages.");
 init_subr_1("probe_file",probe_file,
 "(probe_file FILENAME)\n\
  Returns t if FILENAME exists and is readable, nil otherwise.");
 init_subr_1("parse-number",parse_number,
 "(parse-number SYMBOL)\n\
  Returns a number form a symbol or string whose print name is a number.");
 init_subr_2("%%stack-limit",stack_limit,
 "(%%stack-limit AMOUNT SILENT)\n\
  Set stacksize to AMOUNT, if SILENT is non nil do it silently.");
 init_subr_1("intern",intern,
 "(intern ATOM)\n\
  Intern ATOM on the oblist.");
 init_subr_2("%%closure",closure,
 "(%%closure ENVIRONMENT CODE)\n\
  Make a closure from given environment and code.");
 init_subr_1("%%closure-code",closure_code,
 "(%%closure-code CLOSURE)\n\
  Return code part of closure.");
 init_subr_1("%%closure-env",closure_env,
 "(%%closure-env CLOSURE)\n\
  Return environment part of closure.");
 init_subr_0("getpid",lgetpid,
 "(getpid)\n\
  Return process id.");
 init_fsubr("cd",lchdir,
 "(cd DIRNAME)\n\
  Change directory to DIRNAME, if DIRNAME is nil or not specified \n\
  change directory to user's HOME directory.");
 init_subr_0("pwd",lpwd,
 "(pwd)\n\
  Returns current directory as a string.");
 init_subr_1("getenv",lgetenv,
 "(getenv VARNAME)\n\
  Returns value of UNIX environment variable VARNAME, or nil if VARNAME\n\
  is unset.");
 init_subr_1("set_backtrace",set_backtrace,
 "(set_backtrace arg)\n\
  If arg is non-nil a backtrace will be display automatically after errors\n\
  if arg is nil, a backtrace will not automatically be displayed (use\n\
  (:backtrace) for display explicitly.");
 init_subr_2("setenv",lsetenv,
 "(setenv VARNAME VALUE)\n\
  Set the UNIX environment variable VARNAME to VALUE.");
 init_subr_1("system",lsystem,
 "(system COMMAND)\n\
  Execute COMMAND (a string) with the UNIX shell.");
 init_subr_1("delete-file",lunlink,
 "(delete-file FILENAME)\n\
  Delete named file.");
}

void init_subrs_1e(void)
{
 init_subr_1("print_string",lisp_to_string,
 "(print_string DATA)\n\
  Returns a string representing the printing of DATA." );
 init_subr_1("downcase",symbol_downcase,
 "(downcase SYMBOL)\n\
  Returns a string with the downcased version of SYMBOL's printname.");
 init_subr_1("upcase",symbol_upcase,
 "(upcase SYMBOL)\n\
  Returns a string with the upcased version of SYMBOL's printname.");
 init_subr_1("nint",l_nint,
 "(nint NUMBER)\n\
  Returns nearest int to NUMBER.");
 init_subr_2("string-matches",l_matches,
 "(string-matches ATOM REGEX)\n\
  Returns t if ATOM's printname matches the regular expression REGEX,\n\
  otherwise it returns nil.");
 init_subr_2("string-equal",l_strequal,
 "(string-equal ATOM1 ATOM2)\n\
  Returns t if ATOM's printname is equal to ATOM's print name, otherwise\n\
  it returns nil.");
 init_subr_3("substring", l_substring,
 "(substring STRING START LENGTH)\n\
  Return a substring of STRING starting at START of length LENGTH.");
 init_subr_2("string-before",l_sbefore,
 "(string-before ATOM BEFORE)\n\
  Returns an atom whose printname is the substring of ATOM's printname \n\
  which appears before BEFORE.  This is a wraparound for the EST_String.before \n\
  function in C++, and hence has the same conditions for boundary cases.");
 init_subr_2("string-after",l_safter,
 "(string-after ATOM AFTER)\n\
  Returns an atom whose printname is the substring of ATOM's printname \n\
  which appears after AFTER.  This is a wraparound for the EST_String.after \n\
  function in C++, and hence has the same conditions for boundary cases.");
 init_subr_2("basename",symbol_basename,
 "(basename PATH SUFFIX)\n\
  Return a string with directory removed from basename.  If SUFFIX is\n\
  specified remove that from end of PATH.  Basically the same function\n\
  as the UNIX command of the same name.");

 init_subr_2("directory-entries", directory_entries,
 "(directory-entries DIRECTORY &opt NOFLAGDIR)\n\
  Return a list of the entries in the directory. If NOFLAGDIR is non-null\n\
  don't check to see which are directories.");

 init_subr_1("path-is-filename", path_is_filename,
 "(path-is-filename PATHNAME)\n\
  Is PATH a non-directory name.");

 init_subr_1("path-as-directory", path_as_directory,
 "(path-as-directory PATHNAME)\n\
  Return PATH as a directory name.");

 init_subr_1("path-as-file", path_as_file,
 "(path-as-file PATHNAME)\n\
  Return PATH as a non-directory name.");

 init_lsubr("path-append", path_append,
 "(path-append DIRECTORY-PATH ADDITION1 ADDITION2 ...)\n\
  Return a the path for ADDITION in DIRECTORY.");

 init_subr_1("path-basename", path_basename,
 "(path-basename PATHNAME)\n\
  Return name part of PATH.");


 init_subr_1("path-is-dirname", path_is_dirname,
 "(path-is-dirname PATHNAME)\n\
  Is PATH a directory name.");

 init_fsubr("doc",siod_doc,
 "(doc SYMBOL)\n\
  Return documentation for SYMBOL.");
 init_subr_2("sort-and-dump-docstrings",siod_sort_and_dump_docstrings,
 "(sort-and-dump-docstrings DOCSTRINGS FILEFP)\n\
  DOCSTRINGS is an assoc list of name and document string var-docstrings\n\
  or func-docstrings.  This very individual function sorts the list and \n\
  prints out the documentation strings as texinfo list members to FILEFP.");
 init_subr_1("send_client",siod_send_lisp_to_client,
 "(send_client EXPR)\n\
 Send EXPR to client.  In server mode this will send a printed form of\n\
 ESPR to the client.  It is the client's job to expect it.");
 init_subr_2("pprintf",siod_pprintf,
 "(pprintf EXP [FD])\n\
 Pretty print EXP to FD, if FD is nil print to the screen.");
 init_subr_1("set_server_safe_functions",set_restricted,
 "(set_server_safe_functions LIST)\n\
 Sets restricted list to LIST.  When restricted list is non-nil only\n\
 functions whose names appear in this list may be executed.  This\n\
 is used so that clients in server mode may be restricted to a small\n\
 number of safe commands.  [see Server/client API]");
 init_fsubr("unwind-protect",l_unwind_protect,
 "(unwind_protect NORMALFORM ERRORFORM)\n\
 If an error is found while evaluating NORMALFORM catch it and evaluate\n\
 ERRORFORM and continue.  If an error occurs while evaluating NORMALFORM\n\
 all file open evaluating NORMALFORM up to the error while be automatically\n\
 closed");
 init_subr_1("log",l_log,
 "(log NUM)\n\
 Return natural log of NUM.");
 init_subr_0("rand",l_rand,
 "(rand)\n\
 Returns a pseudo random number between 0 and 1 using the libc rand()\n\
 function.");
 init_subr_1("exp",l_exp,
 "(exp NUM)\n\
 Retrun e**NUM.");
 init_subr_1("sqrt",l_sqrt,
 "(sqrt NUM)\n\
 Retrun square root of NUM.");
 init_subr_2("pow",l_pow,
 "(pow X Y)\n\
 Retrun X**Y.");

}

void init_subrs_1(void)
{
  init_subrs_1a();
  init_subrs_1b();
  init_subrs_1c();
  init_subrs_1d();
  init_subrs_1e();
}

/* err0,pr,prp are convenient to call from the C-language debugger */

void err0(void)
{err("0",NIL);}

void pr(LISP p)
{if ((p >= heap_org) &&
     (p < heap_end) &&
     (((((char *)p) - ((char *)heap_org)) % sizeof(struct obj)) == 0))
   lprint(p);
 else
   put_st("invalid\n");}

void prp(LISP *p)
{if (!p) return;
 pr(*p);}

LISP siod_doc(LISP args,LISP penv)
{
    /* Return documentation string for sym */
    (void)penv;
    LISP lpair,val,tmp,code;
    LISP var_docstrings;

    if (TYPE(car(args)) != tc_symbol)
	return rintern("No documentation available for non-symbol.");
    tmp = envlookup(car(args),penv);
    if NNULLP(tmp) 
	val = car(tmp);
    else
	val = VCELL(car(args));
    if EQ(val,unbound_marker)
	return rintern("Symbol is unbound.");
    else
    {
	var_docstrings = symbol_value(rintern("var-docstrings"),penv);
	lpair = assq(car(args),var_docstrings);
	if (lpair)
	    return cdr(lpair);
	else
	    rintern("No documentation available for symbol.");	    
    }
    switch (TYPE(val))
    {
      case tc_subr_0:
      case tc_subr_1:
      case tc_subr_2:
      case tc_subr_3:
      case tc_subr_4:
      case tc_lsubr:
      case tc_fsubr:
      case tc_msubr:
	lpair = assq(car(args),siod_docstrings);
	if (lpair != NIL)
	    return cdr(lpair);
	else
	    return rintern("No documentation available for builtin function.");
	break;
      case tc_closure:
	code = val->storage_as.closure.code;
	if ((TYPE(cdr(code)) == tc_cons) &&
	    (TYPE(car(cdr(cdr(code)))) == tc_string))
	    return car(cdr(cdr(code)));
	else
	    return rintern("No documentation available for user-defined function.");
      default:
	return rintern("No documentation available for symbol.");
    }
	
    return rintern("No documentation available for symbol.");
}

LISP siod_make_typed_cell(long type, void *s)
{
    LISP ptr;

    NEWCELL(ptr,type);
    USERVAL(ptr) = s;

    return ptr;
}

LISP probe_file(LISP fname)
{
    // return t if file exists, nil otherwise
    char *filename;

    filename = get_c_string(fname);
    if (access(filename,R_OK) == 0)
	return truth;
    else
	return NIL;
}

static LISP set_restricted(LISP l)
{
    // Set restricted list
    
    if (restricted == NIL)
	gc_protect(&restricted);
    
    restricted = l;
    return NIL;
}

static int restricted_function_call(LISP l)
{
    // Checks l recursively to ensure all function calls
    // are in the restricted list
    LISP p;
    
    if (l == NIL)
	return TRUE;
    else if (!consp(l))
	return TRUE;
    else if (TYPE(car(l)) == tc_symbol)
    {
	if (streq("quote",get_c_string(car(l))))
	    return TRUE;
	else if (siod_member_str(get_c_string(car(l)),restricted) == NIL)
	    return FALSE;
    }
    else if (restricted_function_call(car(l)) == FALSE)
	return FALSE;

    // As its some type of list with a valid car, check the cdr
    for (p=cdr(l); consp(p); p=cdr(p))
	if (restricted_function_call(car(p)) == FALSE)
	    return FALSE;
    return TRUE;
}