/* Scheme implementation intended for JACAL.
   Copyright (C) 1990, 1991, 1992 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
*/

typedef long SCM;
typedef struct {SCM car,cdr;} cell;
typedef struct {long sname;SCM (*cproc)();} subr;
typedef struct {char *string;SCM (*cproc)();} iproc;

#include "config.h"

typedef struct {
    SCM (*mark)();
    sizet (*free)();
    int (*print)();
    SCM (*equalp)();
} smobfuns;

#ifdef FLOATS
typedef struct {char *string;double (*cproc)();} dblproc;
#ifdef SINGLES
typedef struct {SCM type;float num;} flo;
#endif
typedef struct {SCM type;double *real;} dbl;
#endif

#define IMP(x) (6 & (int)(x))
#define NIMP(x) (!IMP(x))

#define INUMP(x) (2 & (int)(x))
#define NINUMP(x) (!INUMP(x))
#define MAKINUM(x) (((x)<<2)+2L)
#define INUM0 ((SCM) 2)
#define INUM(x) SRS(x,2)
#define ICHRP(x) ((0xff & (int)(x))==0xf4)
#define ICHR(x) ((unsigned char)((x)>>8))
#define MAKICHR(x) (((x)<<8)+0xf4L)

#define ILOCP(n) ((0xff & (int)(n))==0xfc)
#define ILOC00	(0x000000fcL)
#define IDINC	(0x00010000L)
#define ICDR	(0x00008000L)
#define IFRINC	(0x00000100L)
#define IDSTMSK	(-IDINC)
#define IFRAME(n) ((int)((ICDR-IFRINC)>>8) & ((int)(n)>>8))
#define IDIST(n) (((unsigned long)(n))>>16)
#define ICDRP(n) (ICDR & (n))

/* ISYMP tests for ISPCSYM and ISYM */
#define ISYMP(n) ((0x187 & (int)(n))==4)
/* IFLAGP tests for ISPCSYM, ISYM and IFLAG */
#define IFLAGP(n) ((0x87 & (int)(n))==4)
#define ISYMNUM(n) ((int)((n)>>9))
#define ISYMCHARS(n) (isymnames[ISYMNUM(n)])
#define MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L)
#define MAKISYM(n) (((n)<<9)+0x74L)
#define MAKIFLAG(n) (((n)<<9)+0x174L)

extern char *isymnames[];
#define IM_AND MAKSPCSYM(0)
#define IM_BEGIN MAKSPCSYM(1)
#define IM_CASE MAKSPCSYM(2)
#define IM_COND MAKSPCSYM(3)
#define IM_DEFINE MAKSPCSYM(4)
#define IM_DO MAKSPCSYM(5)
#define IM_IF MAKSPCSYM(6)
#define IM_LAMBDA MAKSPCSYM(7)
#define IM_LET MAKSPCSYM(8)
#define IM_LETSTAR MAKSPCSYM(9)
#define IM_LETREC MAKSPCSYM(10)
#define IM_OR MAKSPCSYM(11)
#define IM_QUOTE MAKSPCSYM(12)
#define IM_SET MAKSPCSYM(13)

/* each symbol defined here must have a unique number which */
 /* corresponds to it's position in isymnames[] in sys.c */

#define I_AND MAKISYM(14)
#define I_BEGIN MAKISYM(15)
#define I_CASE MAKISYM(16)
#define I_COND MAKISYM(17)
#define I_DEFINE MAKISYM(18)
#define I_DO MAKISYM(19)
#define I_IF MAKISYM(20)
#define I_LAMBDA MAKISYM(21)
#define I_LET MAKISYM(22)
#define I_LETSTAR MAKISYM(23)
#define I_LETREC MAKISYM(24)
#define I_OR MAKISYM(25)
#define I_QUOTE MAKISYM(26)
#define I_SET MAKISYM(27)

#define I_QUASIQUOTE MAKISYM(28)
#define I_DEFINEDP MAKISYM(29)
#define I_DELAY MAKISYM(30)

#define NUM_XSPCSYMS 31

#define I_ARROW MAKISYM(NUM_XSPCSYMS+0)
#define I_ELSE MAKISYM(NUM_XSPCSYMS+1)
#define I_UNQUOTE MAKISYM(NUM_XSPCSYMS+2)
#define I_UQ_SPLICING MAKISYM(NUM_XSPCSYMS+3)
#define I_DOT MAKISYM(NUM_XSPCSYMS+4)
#define NUM_ISYMS (NUM_XSPCSYMS+5)

#define BOOL_F MAKIFLAG(NUM_ISYMS+0)
#define BOOL_T MAKIFLAG(NUM_ISYMS+1)
#define UNDEFINED MAKIFLAG(NUM_ISYMS+2)
#define EOF_VAL MAKIFLAG(NUM_ISYMS+3)
#define EOL MAKIFLAG(NUM_ISYMS+4)
#define UNSPECIFIED MAKIFLAG(NUM_ISYMS+5)

#define FALSEP(x) ((x) == BOOL_F)
#define NFALSEP(x) ((x) != BOOL_F)
/* BOOL_NOT returns the other boolean.  The order of ^s here is
   important for Borland C++. */
#define BOOL_NOT(x)  ((x) ^ (BOOL_T ^ BOOL_F))
#define NULLP(x) ((x) == EOL)
#define NNULLP(x) ((x) != EOL)
#define UNBNDP(x) ((x) == UNDEFINED)
#define CELLP(x) (!NCELLP(x))
#define NCELLP(x) ((sizeof(cell)-1) & (int)(x))

#define GCMARKP(x) (1 & (int)CDR(x))
#define GC8MARKP(x) (0x80 & (int)CAR(x))
#define SETGCMARK(x) CDR(x) |= 1;
#define CLRGCMARK(x) CDR(x) &= ~1L;
#define SETGC8MARK(x) CAR(x) |= 0x80;
#define CLRGC8MARK(x) CAR(x) &= ~0x80L;
#define TYP3(x) (7 & (int)CAR(x))
#define TYP7(x) (0x7f & (int)CAR(x))
#define TYP7S(x) (0x7d & (int)CAR(x))
#define TYP16(x) (0xffff & (int)CAR(x))
#define TYP16S(x) (0xfeff & (int)CAR(x))
#define GCTYP16(x) (0xff7f & (int)CAR(x))

#define NCONSP(x) (1 & (int)CAR(x))
#define CONSP(x) (!NCONSP(x))
#define ECONSP(x) (CONSP(x) || (TYP3(x) == 1))
#define NECONSP(x) (NCONSP(x) && (TYP3(x) != 1))
#define CAR(x) (((cell *)(x))->car)
#define CDR(x) (((cell *)(x))->cdr)
#define GCCDR(x) (~1L & CDR(x))
#define SETCDR(x,v) CDR(x)=(SCM)(v)

#define CLOSUREP(x) (TYP3(x) == tc3_closure)
#define CODE(x) (CAR(x)-tc3_closure)
#define SETCODE(x,e) CAR(x)=(e)+tc3_closure
#define ENV(x) CDR(x)

#define PORTP(x) ((0x8ffff & CAR(x)) == tc16_port)
#define PIPEP(x) ((0x8ffff & CAR(x)) == (tc16_port | PIP))
#define OPPORTP(x) ((0x1ffff & ~PIP & CAR(x)) == (tc16_port | OPN))
#define OPINPORTP(x) ((~WRTNG & ~PIP & CAR(x)) == tc_inport)
#define OPOUTPORTP(x) ((~RDNG & ~PIP & CAR(x)) == tc_outport)
#define INPORTP(x) ((~WRTNG & ~OPN & ~PIP & CAR(x)) == (tc_inport & ~OPN))
#define OUTPORTP(x) ((~RDNG & ~OPN & ~PIP & CAR(x)) == (tc_outport & ~OPN))
#define OPENP(x) (OPN & CAR(x))
#define CLOSEDP(x) (!OPENP(x))
#define STREAM(x) ((FILE *)(CDR(x)))
#define SETSTREAM(x,v) SETCDR(x,v)

#ifdef FLOATS
#define INEXP(x) (TYP16(x) == tc16_flo)
#define CPLXP(x) (CAR(x) == tc_dblc)
#define REAL(x) (*(((dbl *) (x))->real))
#define IMAG(x) ((&REAL(x))[1])
#ifdef SINGLES
#define REALP(x) ((~REAL_PART & CAR(x))==tc_flo)
#define SINGP(x) (CAR(x)==tc_flo)
#define FLO(x) (((flo *) (x))->num)
#define REALPART(x) (SINGP(x)?0.0+FLO(x):REAL(x))
#else /* SINGLES */
#define REALP(x) (CAR(x)==tc_dblr)
#define REALPART(x) REAL(x)
#endif /* SINGLES */
#endif

#ifdef FLOATS
# define NUMBERP(x) (INUMP(x) || (NIMP(x) && NUMP(x)))
#else
# ifdef BIGDIG
#  define NUMBERP(x) (INUMP(x) || (NIMP(x) && NUMP(x)))
# else
#  define NUMBERP(x) INUMP(x)
# endif
#endif
#define NUMP(x) ((0xfcff & (int)(CAR(x))) == tc7_smob)
#define BIGP(x) (TYP16S(x) == tc16_bigpos)
#define BDIGITS(x) ((BIGDIG *)(CDR(x)))
#define NUMDIGS(x) (CAR(x)>>16)
#define SETNUMDIGS(x,v,t) CAR(x) = ((v)<<16L)+(t)

#define SNAME(x) (heap_org+(CAR(x)>>8))
#define SETSNAME(x,v,t) CAR(x)=((((CELLPTR)(v))-heap_org)<<8)+(t)
#define SUBRF(x) (((subr *)(x))->cproc)

#define SYMBOLP(x) (TYP7S(x) == tc7_ssymbol)
#define STRINGP(x) (TYP7(x) == tc7_string)
#define NSTRINGP(x) (!STRINGP(x))
#define VECTORP(x) (TYP7(x) == tc7_vector)
#define NVECTORP(x) (!VECTORP(x))
#define LENGTH(x) (CAR(x)>>8)
#define SETLENGTH(x,v,t) CAR(x) = ((v)<<8)+(t)
#define CHARS(x) ((char *)(CDR(x)))
#define VELTS(x) ((SCM *)CDR(x))
#define SETCHARS(x,v) SETCDR(x,v)
#define SETVELTS(x,v) SETCDR(x,v)

#define FREEP(x) (CAR(x) == tc_free_cell)
#define NFREEP(x) (!FREEP(x))

#define SMOBNUM(x) (0x0ff & (CAR(x)>>8));

/* Aggregated types for dispatch in switch statements. */

#define tcs_cons_imcar 2:case 4:case 6:case 10:\
		 case 12:case 14:case 18:case 20:\
		 case 22:case 26:case 28:case 30:\
		 case 34:case 36:case 38:case 42:\
		 case 44:case 46:case 50:case 52:\
		 case 54:case 58:case 60:case 62:\
		 case 66:case 68:case 70:case 74:\
		 case 76:case 78:case 82:case 84:\
		 case 86:case 90:case 92:case 94:\
		 case 98:case 100:case 102:case 106:\
		 case 108:case 110:case 114:case 116:\
		 case 118:case 122:case 124:case 126
#define tcs_cons_nimcar 0:case 8:case 16:case 24:\
		 case 32:case 40:case 48:case 56:\
		 case 64:case 72:case 80:case 88:\
		 case 96:case 104:case 112:case 120
#define tcs_cons_gloc 1:case 9:case 17:case 25:\
		 case 33:case 41:case 49:case 57:\
		 case 65:case 73:case 81:case 89:\
		 case 97:case 105:case 113:case 121

#define tcs_closures   3:case 11:case 19:case 27:\
		 case 35:case 43:case 51:case 59:\
		 case 67:case 75:case 83:case 91:\
		 case 99:case 107:case 115:case 123
#define tcs_subrs tc7_asubr:case tc7_subr_0:case tc7_subr_1:case tc7_cxr:\
	case tc7_subr_3:case tc7_subr_2:case tc7_subr_2x:case tc7_subr_1o:\
	case tc7_subr_2o:case tc7_lsubr_2:case tc7_lsubr
#define tcs_symbols tc7_ssymbol:case tc7_msymbol
#define tcs_bignums tc16_bigpos:case tc16_bigneg

#define tc3_cons	0
#define tc3_cons_gloc	1
#define tc3_closure	3

#define tc7_ssymbol	5
#define tc7_msymbol	7
#define tc7_string	13
#define tc7_vector	15
#define tc7_bvect	21
/* spare 23 */
#define tc7_ivect	29
#define tc7_uvect	31
/* spare 37 39 */
#define tc7_fvect	45
#define tc7_dvect	47
#define tc7_cvect	53
/* spare 55 */
#define tc7_contin	61
#define tc7_cclo	63

/* spare 71 77 */
#define tc7_asubr	79
#define tc7_subr_0	85
#define tc7_subr_1	87
#define tc7_cxr		93
#define tc7_subr_3	95
#define tc7_subr_2	101
#define tc7_subr_2x	103
#define tc7_subr_1o	109
#define tc7_subr_2o	111
#define tc7_lsubr_2	117
/* spare 119 */
#define tc7_lsubr	125

#define tc7_smob	127
#define tc_free_cell	127

#define tc16_flo	0x017f
#define tc_flo		0x017fL

#define REAL_PART	(1L<<16)
#define IMAG_PART	(2L<<16)
#define tc_dblr		(tc16_flo|REAL_PART)
#define tc_dblc		(tc16_flo|REAL_PART|IMAG_PART)

#define tc16_bigpos	0x027f
#define tc16_bigneg	0x037f

#define tc16_port	0x047f
#define OPN		(1L<<16)
#define RDNG		(2L<<16)
#define WRTNG		(4L<<16)
#define PIP		(8L<<16)
#define tc_inport	(tc16_port|OPN|RDNG)
#define tc_outport	(tc16_port|OPN|WRTNG)
#define tc_ioport	(tc16_port|OPN|RDNG|WRTNG)
#define tc_inpipe	(tc16_port|OPN|RDNG|PIP)
#define tc_outpipe	(tc16_port|OPN|WRTNG|PIP)

#define SMOBMIN		0x05

extern smobfuns *smobs;
extern sizet numsmob;

extern SCM sys_protects[];
#define cur_inp sys_protects[0]
#define cur_outp sys_protects[1]
#define listofnull sys_protects[2]
#define undefineds sys_protects[3]
#define nullvect sys_protects[4]
#define nullstr sys_protects[5]
#define symhash sys_protects[6]
#define progargs sys_protects[7]
#define transcript sys_protects[8]
#define def_inp sys_protects[9]
#define def_outp sys_protects[10]
#ifdef FLOATS
# define flo0 sys_protects[11]
# define NUM_PROTECTS 12
#else
# define NUM_PROTECTS 11
#endif

/* now for connects between source files */

extern unsigned char upcase[],downcase[];
extern int symhash_dim;
extern long heap_size;
extern SCMPTR stack_start_ptr;
extern CELLPTR heap_org;
extern SCM freelist;
extern long gc_cells_collected,	gc_malloc_collected, gc_ports_collected;
extern long cells_allocated;
extern long linum;
extern int errjmp_ok, ints_disabled, sig_deferred, alrm_deferred;
void han_sig(), han_alrm();
char *must_malloc();
long ilength();

extern char s_read[], s_write[], s_newline[];
extern char s_make_string[], s_make_vector[], s_list[];
#define s_string (s_make_string+5)
#define s_vector (s_make_vector+5)

SCM repl_driver();
long newsmob();
void make_subr();
void repl(), gc_end(), gc_start(), growth_mon(), lthrow();
void iprin1(), intprint(), iprlist(), lputc(), lputs();
int lfwrite();
long time_in_msec();
SCM my_time();
void init_tables(), init_storage(), init_subrs(), init_features();
void init_iprocs(), init_scm(), init_scl(), init_io(), init_repl();
void init_time(), init_signals(), ignore_signals(), unignore_signals();
void init_eval(), init_sc2();
void init_unif(), uvprin1();
SCM markcdr();
sizet free0();
void warn(), wta(), everr();
SCM sysintern(), intern(), sym2vcell(), makstr(), makfromstr(), closure();
SCM makprom(), force(), makarb(), tryarb(), relarb();
SCM ceval(), prolixity(), gc(), gc_for_newcell();
SCM tryload();
SCM cons2(),cons2r(),resizuve();

SCM lnot(), booleanp(), eq(), equal();
SCM consp(), cons(), nullp();
SCM setcar(), setcdr();
SCM listp(), list(), length(), append(), reverse(), list_ref();
SCM memq(), memv(), member(), assq(), assoc();
SCM symbolp(), symbol2string(), string2symbol();
SCM numberp(), exactp(), inexactp();
SCM eqp(), lessp();
SCM zerop(), positivep(), negativep(), oddp(), evenp();
SCM lmax(), lmin(), sum(), product(), difference(), quotient(), absval();
SCM lremainder(), modulo(), lgcd(), llcm(), number2string(), string2number();
SCM makdbl(),istr2flo(),mkbig(),long2big(),dbl2big();
sizet iint2str(),iflo2str();
void floprint(), bigprint();
#ifdef FLOATS
double big2dbl();
#endif
SCM charp(), char_lessp(), chci_eq(), chci_lessp();
SCM char_alphap(), char_nump(), char_whitep(), char_upperp(), char_lowerp();
SCM char2int(), int2char(), char_upcase(), char_downcase();
SCM stringp(), make_string(), string();
SCM st_length(), st_ref(), st_set();
SCM st_equal(), stci_equal();
SCM st_lessp(), stci_lessp(), substring(), st_append();

SCM vectorp(), make_vector(), vector(), vector_length();
SCM vector_ref(), vector_set();
SCM for_each(), procedurep(), apply(), map(), call_cc();
extern SCM throwval, quit();

SCM input_portp(), output_portp(), cur_input_port(), cur_output_port();
SCM open_file(), open_pipe(), close_port(), close_pipe();
SCM lread(), read_char(), peek_char(), eof_objectp();
SCM lwrite(), display(), newline(), write_char();
#ifdef IO_EXTENSIONS
SCM file_position(), file_set_position();
#endif
SCM lgetenv(), prog_args();

#define DIGITS '0':case '1':case '2':case '3':case '4':\
		case '5':case '6':case '7':case '8':case '9'

#ifdef RECKLESS
#define ASSERT(_cond,_arg,_pos,_subr) ;
#define ASRTGO(_cond,_label) ;
#else
#define ASSERT(_cond,_arg,_pos,_subr) if(!(_cond))wta(_arg,(char *)_pos,_subr);
#define ASRTGO(_cond,_label) if(!(_cond)) goto _label;
#endif

#define ARG1 1
#define ARG2 2
#define ARG3 3
#define ARG4 4
#define ARG5 5
  /* following must match entry indexes in errmsgs[] */
#define WNA 6
#define OVFLOW 7
#define OUTOFRANGE 8
#define NALLOC 9
#define EXIT 10
#define HUP_SIGNAL 11
#define INT_SIGNAL 12
#define FPE_SIGNAL 13
#define BUS_SIGNAL 14
#define SEGV_SIGNAL 15
#define ALRM_SIGNAL 16

#define EVAL(x,env) (IMP(x)?(x):ceval((x),(env)))
#define SIDEVAL(x,env) if NIMP(x) ceval((x),(env))

#define NEWCELL(_into) {if IMP(freelist) _into = gc_for_newcell();\
	else {_into = freelist;freelist = CDR(freelist);++cells_allocated;}}
