/* Scheme implementation intended for JACAL.
   Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 Aubrey Jaffer.
   
   This program is free software; you can redistribute it and/or modify
   it under the terms of the GNU General Public License as published by
   the Free Software Foundation; either version 1, or (at your option)
   any later version.
   
   This program is distributed in the hope that it will be useful,
   but WITHOUT ANY WARRANTY; without even the implied warranty of
   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   GNU General Public License for more details.
   
   You should have received a copy of the GNU General Public License
   along with this program; if not, write to the Free Software
   Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   
   The author can be reached at jaffer@ai.mit.edu or
   Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880
   */

#include <stdio.h>
#include "params.h"

typedef long SCM;
typedef struct scm_cell
{
  SCM car, cdr;
} scm_cell;
typedef struct scm_subr
{
  long sname;
  SCM (*cproc) ();
} scm_subr;
typedef struct scm_iproc
{
  char *scm_string;
  SCM (*cproc) ();
} scm_iproc;
typedef struct scm_dsubr
{
  long sname;
  double (*dproc) ();
} scm_dsubr;

#include "scmfig.h"

typedef struct scm_smobfuns
{
  SCM (*mark) P ((SCM));
  sizet (*free) P ((CELLPTR));
  int (*print) P ((SCM exp, SCM port, int writing));
  SCM (*equalp) P ((SCM, SCM));
} scm_smobfuns;

typedef struct scm_ptobfuns
{
  SCM (*mark) P ((SCM ptr));
  int (*free) P ((FILE * p));
  int (*print) P ((SCM exp, SCM port, int writing));
  SCM (*equalp) P ((SCM, SCM));
  int (*fputc) P ((int c, FILE * p));
  int (*fputs) P ((char *s, FILE * p));
  sizet (*fwrite) P ((char *s, sizet siz, sizet num, FILE * p));
  int (*fflush) P ((FILE * stream));
  int (*fgetc) P ((FILE * p));
  int (*fclose) P ((FILE * p));
} scm_ptobfuns;

typedef struct scm_array
{
  SCM v;
  sizet base;
} scm_array;
typedef struct scm_array_dim
{
  long lbnd;
  long ubnd;
  long inc;
} scm_array_dim;

#ifdef FLOATS
typedef struct scm_dblproc
{
  char *scm_string;
  double (*cproc) P ((double));
} scm_dblproc;
#ifdef SINGLES
typedef struct scm_flo
{
  SCM type;
  float num;
} scm_flo;
#endif
typedef struct scm_dbl
{
  SCM type;
  double *real;
} scm_dbl;
#endif



struct errdesc
{
  char *msg;
  char *s_response;
  short parent_err;
};


extern struct errdesc scm_errmsgs[];



struct scm_port_table 
{
  SCM port;			/* Open port.  */
  int revealed;			/* 0 not revealed, > 1 revealed.
				 * Revealed ports do not get GC'd.
				 */
};

extern struct scm_port_table *scm_port_table;
extern scm_port_table_size; /* Number of ports in scm_port_table.  */



/* {Formats of SCM words.}
 */

/* Some SCM words hold data + tag bits (immedatiate words),
 * others hold pointers.  IMP and NIMP distinguish the two cases.
 */
#define IMP(x) (6 & (int)(x))
#define NIMP(x) (!IMP(x))

/* Immediate numbers -- integer data that fits within an SCM word.
 */
#define INUMP(x) (2 & (int)(x))
#define NINUMP(x) (!INUMP(x))

/* A name for exact 0.
 */
#define INUM0 ((SCM) 2)

/* Immediate characters.
 */
#define ICHRP(x) ((0xff & (int)(x))==0xf4)
#define ICHR(x) ((unsigned char)((x)>>8))
#define MAKICHR(x) (((x)<<8)+0xf4L)

/* Local environment structure.
 */
#define ILOCP(n) ((0xff & (int)(n))==0xfc)
#define ILOC00	(0x000000fcL)
#define IDINC	(0x00100000L)
#define ICDR	(0x00080000L)
#define IFRINC	(0x00000100L)
#define IDSTMSK	(-IDINC)
#define IFRAME(n) ((int)((ICDR-IFRINC)>>8) & ((int)(n)>>8))
#define IDIST(n) (((unsigned long)(n))>>20)
#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) (scm_isymnames[ISYMNUM(n)])
#define MAKSPCSYM(n) (((n)<<9)+((n)<<3)+4L)
#define MAKISYM(n) (((n)<<9)+0x74L)
#define MAKIFLAG(n) (((n)<<9)+0x174L)


/* {Immediate symbols}
 * 
 * This table must agree with the declarations 
 * in repl.c: {Names of immediate symbols}.
 */

extern char *scm_isymnames[];

#define IM_AND MAKSPCSYM(0)
#define IM_BEGIN MAKSPCSYM(1)
#define IM_CASE MAKSPCSYM(2)
#define IM_COND MAKSPCSYM(3)
#define IM_DO MAKSPCSYM(4)
#define IM_IF MAKSPCSYM(5)
#define IM_LAMBDA MAKSPCSYM(6)
#define IM_LET MAKSPCSYM(7)
#define IM_LETSTAR MAKSPCSYM(8)
#define IM_LETREC MAKSPCSYM(9)
#define IM_OR MAKSPCSYM(10)
#define IM_QUOTE MAKSPCSYM(11)
#define IM_SET MAKSPCSYM(12)
#define IM_DEFINE MAKSPCSYM(13)
#if 0
#define IM_VREF MAKISYM(14)
#define IM_VSET MAKISYM(15)
#endif
#define IM_APPLY MAKISYM(14)
#define IM_CONT MAKISYM(15)
#define NUM_ISYMS 16

#define s_and (ISYMCHARS(IM_AND)+2)
#define s_begin (ISYMCHARS(IM_BEGIN)+2)
#define s_case (ISYMCHARS(IM_CASE)+2)
#define s_cond (ISYMCHARS(IM_COND)+2)
#define s_do (ISYMCHARS(IM_DO)+2)
#define s_if (ISYMCHARS(IM_IF)+2)
#define s_lambda (ISYMCHARS(IM_LAMBDA)+2)
#define s_let (ISYMCHARS(IM_LET)+2)
#define s_letstar (ISYMCHARS(IM_LETSTAR)+2)
#define s_letrec (ISYMCHARS(IM_LETREC)+2)
#define s_or (ISYMCHARS(IM_OR)+2)
#define s_quote (ISYMCHARS(IM_QUOTE)+2)
#define s_set (ISYMCHARS(IM_SET)+2)
#define s_define (ISYMCHARS(IM_DEFINE)+2)
#if 0
#define s_vref (ISYMCHARS(IM_VREF)+2)
#define s_vset (ISYMCHARS(IM_VSET)+2)
#endif
#define s_apply (ISYMCHARS(IM_APPLY)+2)



/* Normal symbols of importance to the interpreter.
 */

extern SCM scm_i_dot;
extern SCM scm_i_quote;
extern SCM scm_i_quasiquote;
extern SCM scm_i_unquote;
extern SCM scm_i_uq_splicing;


/* Important immediates: 
 */

#define BOOL_F MAKIFLAG(NUM_ISYMS+0)
#define BOOL_T MAKIFLAG(NUM_ISYMS+1)
#define SCM_UNDEFINED MAKIFLAG(NUM_ISYMS+2)
#define EOF_VAL MAKIFLAG(NUM_ISYMS+3)

#ifdef SICP
#define EOL BOOL_F
#else
#define EOL MAKIFLAG(NUM_ISYMS+4)
#endif

#define UNSPECIFIED MAKIFLAG(NUM_ISYMS+5)



#define FALSEP(x) (BOOL_F==(x))
#define NFALSEP(x) (BOOL_F != (x))

/* 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) (EOL == (x))
#define NNULLP(x) (EOL != (x))
#define UNBNDP(x) (SCM_UNDEFINED==(x))
#define CELLP(x) (!NCELLP(x))
#define NCELLP(x) ((sizeof(scm_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) || (1==TYP3(x)))
#define NECONSP(x) (NCONSP(x) && (1 != TYP3(x)))

#define CAR(x) (((scm_cell *)(SCM2PTR(x)))->car)
#define CDR(x) (((scm_cell *)(SCM2PTR(x)))->cdr)
#define GCCDR(x) (~1L & CDR(x))
#define SETCDR(x, v) CDR(x) = (SCM)(v)

#define CLOSUREP(x) (TYP3(x)==tc3_closure)
#define CLOSCAR(x) (CAR(x)-tc3_closure)
#define CODE(x) CAR(CLOSCAR (x))
#define PROCPROPS(x) CDR(CLOSCAR (x))
#define SETCODE(x, e) CAR(x) = (scm_cons ((e), EOL) + tc3_closure)
#define ENV(x) CDR(x)
#define TOP_LEVEL(ENV)  (NULLP(ENV) || (BOOL_T == scm_procedurep (CAR (ENV))))

#define PORTP(x) (TYP7(x)==tc7_port)
#define OPPORTP(x) (((0x7f | OPN) & CAR(x))==(tc7_port | OPN))
#define OPINPORTP(x) (((0x7f | OPN | RDNG) & CAR(x))==(tc7_port | OPN | RDNG))
#define OPOUTPORTP(x) (((0x7f | OPN | WRTNG) & CAR(x))==(tc7_port | OPN | WRTNG))
#define FPORTP(x) (TYP16S(x)==tc7_port)
#define OPFPORTP(x) (((0xfeff | OPN) & CAR(x))==(tc7_port | OPN))
#define OPINFPORTP(x) (((0xfeff | OPN | RDNG) & CAR(x))==(tc7_port | OPN | RDNG))
#define OPOUTFPORTP(x) (((0xfeff | OPN | WRTNG) & CAR(x))==(tc7_port | OPN | WRTNG))

#define INPORTP(x) (((0x7f | RDNG) & CAR(x))==(tc7_port | RDNG))
#define OUTPORTP(x) (((0x7f | WRTNG) & CAR(x))==(tc7_port | WRTNG))
#define OPENP(x) (OPN & CAR(x))
#define CLOSEDP(x) (!OPENP(x))
#define STREAM(x) ((FILE *)(CDR(x)))
#define SETSTREAM SETCDR
#define CRDYP(port) (CAR(port) & CRDY)
#define CLRDY(port) {CAR(port) &= CUC;}
#define CGETUN(port) ((int)SRS(CAR(port), 22))
#define CUNGET(c, port) {CAR(port) += ((long)c<<22) + CRDY;}

#define tc_socket (tc7_port | OPN)
#define SOCKP(x) (((0x7f | OPN | RDNG | WRTNG) & CAR(x))==(tc_socket))
#define SOCKTYP(x) (CAR(x)>>24)

#define DIRP(x) (NIMP(x) && (TYP16(x)==(scm_tc16_dir)))
#define OPDIRP(x) (NIMP(x) && (CAR(x)==(scm_tc16_dir | OPN)))

#ifdef FLOATS
#define INEXP(x) (TYP16(x)==tc16_flo)
#define CPLXP(x) (CAR(x)==tc_dblc)
#define REAL(x) (*(((scm_dbl *) (SCM2PTR(x)))->real))
#define IMAG(x) (*((double *)(CHARS(x)+sizeof(double))))
/* ((&REAL(x))[1]) */
#ifdef SINGLES
#define REALP(x) ((~REAL_PART & CAR(x))==tc_flo)
#define SINGP(x) (CAR(x)==tc_flo)
#define FLO(x) (((scm_flo *)(SCM2PTR(x)))->num)
#define REALPART(x) (SINGP(x)?0.0+FLO(x):REAL(x))
#else /* SINGLES */
#define REALP(x) (CAR(x)==tc_dblr)
#define REALPART REAL
#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 INUMP
#endif
#endif
#define NUMP(x) ((0xfcff & (int)CAR(x))==tc7_smob)
#define BIGP(x) (TYP16S(x)==tc16_bigpos)
#define BIGSIGN(x) (0x0100 & (int)CAR(x))
#define BDIGITS(x) ((BIGDIG *)(CDR(x)))
#define NUMDIGS(x) ((sizet)(CAR(x)>>16))
#define SETNUMDIGS(x, v, t) CAR(x) = (((v)+0L)<<16)+(t)

#define SNAME(x) ((CAR(x)>>8)?(SCM)(scm_heap_org+(CAR(x)>>8)):nullstr)
#define SUBRF(x) (((scm_subr *)(SCM2PTR(x)))->cproc)
#define DSUBRF(x) (((scm_dsubr *)(SCM2PTR(x)))->dproc)
#define CCLO_SUBR(x) (VELTS(x)[0])

extern int scm_tc16_variable;

#define VARVCELL(V) CDR(V)
#define VARIABLEP(X)   (scm_tc16_variable == CAR(X))
#define UDVARIABLEP(X) (VARIABLEP(X) && UNBNDP (CDR (VARVCELL (X))))
#define DEFVARIABLEP(X) (VARIABLEP(X) && !UNBNDP (CDR (VARVCELL (X))))

extern int scm_tc16_key_vector;
#define KEYVECP(X)   (scm_tc16_key_vector == TYP16 (X))
#define KEYVECLEN(OBJ) (((unsigned long)CAR (obj)) >> 16)


#define MALLOCDATA(obj) ((char *)CDR(obj))
#define MALLOCLEN(obj) (((unsigned long)CAR (obj)) >> 16)
#define WORDDATA(obj)  (CDR (obj))

#define struct_i_name 0
#define struct_i_vcell 1
#define struct_i_format (struct_i_vcell + 1)
#define struct_i_refcnt (struct_i_format + 1)
#define struct_i_self (struct_i_refcnt + 1)
#define struct_i_sekrit (struct_i_self + 1)
#define struct_i_vtab_size (struct_i_sekrit + 1)
#define struct_i_vtab  (struct_i_vtab_size + 1)
#define n_header (struct_i_vtab + 1)

#define latte_type_format "S.S.SS*S"
#define STRUCT_TYPE_NAME(x) (VELTS (x)[struct_i_name])
#define STRUCT_TYPE_VCELL(x) (VELTS (x)[struct_i_vcell])
#define STRUCT_TYPE_FORMAT(x) (VELTS (x)[struct_i_format])
#define STRUCT_TYPE_REFCNT(x) (VELTS (x)[struct_i_refcnt])
#define STRUCT_TYPE_SELF(x) (VELTS (x)[struct_i_self])
#define STRUCT_TYPE_SEKRIT(x) (VELTS (x)[struct_i_sekrit])
#define STRUCT_TYPE_VTAB_SIZE(x) (VELTS (x)[struct_i_vtab_size])
#define STRUCT_TYPE_VTAB(x) (&(VELTS (x)[struct_i_vtab]))
#define STRUCT_TYPEP(X) (CAR (X) == (1 + CDR (first_type)))

#define STRUCTP(X)  (TYP3(X) == tc3_cons_gloc)
#define STRUCT_TYPE(X) ((SCM *)(CAR(X) - 1))

#define BYTECODEP(X) ((TYP7 (X) == tc7_cclo) && (CCLO_SUBR (X) == rb_proc))
#define BYTECODE_CONSTANTS(X) (VELTS(X)[1])
#define BYTECODE_CODE(X) (VELTS(X)[2])
#define BYTECODE_NAME(X) (VELTS(X)[3])
#define BYTECODE_BCODE(X) (VELTS(X)[4])
#define BYTECODE_ELTS 5

extern int scm_tc16_kw;
#define KEYWORDP(X)	(CAR(X) == scm_tc16_kw)
#define KEYWORDSYM(X)	(CDR(X))

#define SYMBOLP(x) (TYP7S(x)==tc7_ssymbol)
#define STRINGP(x) (TYP7(x)==tc7_string)
#define ROSTRINGP(x) ((TYP7(x)==tc7_string) || (TYP7S(x) == tc7_ssymbol))
#define NSTRINGP(x) (!STRINGP(x))
#define VECTORP(x) (TYP7(x)==tc7_vector)
#define NVECTORP(x) (!VECTORP(x))
#define LVECTORP(x) (TYP7(x)==tc7_lvector)
#define LVECTOR_KEY(x, n) (VELTS((VELTS(x)[0]))[0])
/* Some lvectors are type objects which describe other lvectors.
 * In those, element 0 is `scm_lvector_type' and the other elements
 * have these names:
 */
#define LV_REF_FN (1)
#define LV_SET_FN (2)
#define LV_PRINT_FN (3)
#define LV_EQUAL_FN (4)
#define LV_ISA_FN (5)
#define LENGTH(x) (((unsigned long)CAR(x))>>8)
#define LENGTH_MAX (0xffffffL)
#define SETLENGTH(x, v, t) CAR(x) = ((v)<<8)+(t)
#define CHARS(x) ((char *)(CDR(x)))
#define UCHARS(x) ((unsigned char *)(CDR(x)))
#define SLOTS(x) ((SCM *) (* ((SCM *)CHARS(x) - 1)))
#define SYMBOL_SLOTS 4
#define SYMBOL_FUNC(X) (SLOTS(X)[0])
#define SYMBOL_PROPS(X) (SLOTS(X)[1])
#define SYMBOL_HASH(X) (*(unsigned long*)(&SLOTS(X)[2]))
#define VELTS(x) ((SCM *)CDR(x))
#define SETCHARS SETCDR
#define SETVELTS SETCDR

extern long scm_tc16_array;
#define ARRAYP(a) (scm_tc16_array==TYP16(a))
#define ARRAY_V(a) (((scm_array *)CDR(a))->v)
/*#define ARRAY_NDIM(x) NUMDIGS(x)*/
#define ARRAY_NDIM(x) ((sizet)(CAR(x)>>17))
#define ARRAY_CONTIGUOUS 0x10000
#define ARRAY_CONTP(x) (ARRAY_CONTIGUOUS & (int)CAR(x))
#define ARRAY_BASE(a) (((scm_array *)CDR(a))->base)
#define ARRAY_DIMS(a) ((scm_array_dim *)(CHARS(a)+sizeof(scm_array)))

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

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

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

/* {Aggregated Types for Dispatch in Switch Statements}
 *
 * The 3 bit tags go this way:
 *    000 - cons cells
 *    001 - gloc  (in CARs in code only -- points to a variable object).
 *    010 - immediate integers
 *    011 - code (in the CARs of closures only)
 *    100 - immediate chars, flags, symbols; in code CARs: ilocs, ipscysms
 *    101 - CAR of some subrs, some mallocs
 *    111 - CAR of smobs, ptobs, some subrs, some mallocs
 *
 * Then there are tags with 7 or more bits. (see code.doc)
 *
 * When dispatching on a non-immediate type, many switch statements use
 * the macro TYP7 to extract seven bits of tag data from the CAR
 * of the object of the dispatch.
 *
 * The macros that follow are convenient switch labels for that kind
 * of code.  They project several 3 bit tags into 7 bit space.
 */

/* For cons pairs with immediate values in the CAR */
#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

/* For cons pairs with non-immediate values in the CAR */
#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

/* A CONS_GLOC occurs in code.  It's CAR is a pointer to the
 * CDR of a variable.  The low order bits of the CAR are 001.
 * The CDR of the gloc is the code continuation.
 */
#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



/* {More Aggregated Types for Dispatch in Switch Statements}
 *
 * These simply combine a number of 7 bit tags into a single label.
 */

#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_rpsubr: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_bvect	15
#define tc7_vector	21
#define tc7_lvector	23
#define tc7_ivect	29
#define tc7_uvect	31
/* spare 37 39 */
#define tc7_fvect	45
#define tc7_dvect	47
#define tc7_cvect	53
#define tc7_port	55
#define tc7_contin	61
#define tc7_cclo	63
/* spare 69 71 77 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_asubr	103
#define tc7_subr_1o	109
#define tc7_subr_2o	111
#define tc7_lsubr_2	117
#define tc7_lsubr	119
#define tc7_rpsubr	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

/* PORT FLAGS
 * A set of flags caracterizes a port.
 */
#define OPN		(1L<<16)/* Is the port open? */
#define RDNG		(2L<<16)/* Is it a readable port? */
#define WRTNG		(4L<<16)/* Is it writable? */
#define BUF0		(8L<<16)
#define CRDY		(32L<<16)	/* Should char-ready? return #t? */
/* A mask used to clear the char-ready port flag. */
#define CUC		0x001fffffL

extern int scm_take_stdin;
extern SCM scm_top_level_lookup_thunk_var;
extern sizet scm_numsmob;
extern sizet scm_numptob;
extern scm_smobfuns * scm_smobs;
extern scm_ptobfuns * scm_ptobs;
extern scm_ptobfuns scm_pipob;
#define tc16_fport (tc7_port + 0*256L)
#define tc16_pipe (tc7_port + 1*256L)
#define tc16_strport (tc7_port + 2*256L)
#define tc16_sfport (tc7_port + 3*256L)
extern long scm_tc16_dir;

extern SCM scm_sys_protects[];
#define cur_inp scm_sys_protects[0]
#define cur_outp scm_sys_protects[1]
#define cur_errp scm_sys_protects[2]
#define def_inp scm_sys_protects[3]
#define def_outp scm_sys_protects[4]
#define def_errp scm_sys_protects[5]
#define listofnull scm_sys_protects[6]
#define undefineds scm_sys_protects[7]
#define nullvect scm_sys_protects[8]
#define nullstr scm_sys_protects[9]
#define symhash scm_sys_protects[10]
#define progargs scm_sys_protects[11]
#define transcript scm_sys_protects[12]
#define rootcont scm_sys_protects[13]
#define dynwinds scm_sys_protects[14]
#define symhash_vars scm_sys_protects[15]
#define permobjs scm_sys_protects[16]
#define flo0 scm_sys_protects[17]
#define kw_obarray scm_sys_protects[18]
#define type_obj_list scm_sys_protects[19]
#define first_type scm_sys_protects[20]
#define NUM_PROTECTS 21


/* now for connects between source files */

extern void (**scm_finals) P ((void));
extern sizet scm_num_finals;
extern unsigned char scm_upcase[];
extern unsigned char scm_downcase[];
extern int scm_symhash_dim;
extern long scm_heap_size;
extern CELLPTR scm_heap_org;
extern SCM scm_freelist;
extern long scm_gc_cells_collected;
extern long scm_gc_malloc_collected;
extern long scm_gc_ports_collected;
extern long scm_cells_allocated;
extern long scm_lcells_allocated;
extern long scm_mallocated;
extern long scm_lmallocated;
extern long scm_mtrigger;
extern SCM *scm_loc_loadpath;
extern SCM loadport;
extern long scm_linum;
extern int scm_errjmp_bad;
extern int scm_ints_disabled;
extern int scm_sig_deferred;
extern int scm_alrm_deferred;
extern SCM scm_throwval;
SCM scm_exitval;
extern int cursinit;
extern unsigned int poll_count, scm_tick_count;
     
/* strings used in several source files */

extern char scm_s_read[], scm_s_write[], scm_s_newline[], scm_s_system[];
extern char scm_s_make_string[], scm_s_make_vector[], scm_s_list[], scm_s_op_pipe[];
#define s_string (scm_s_make_string+5)
#define s_vector (scm_s_make_vector+5)
extern char scm_s_make_sh_array[];
#define s_array (scm_s_make_sh_array+12)
extern char scm_s_ccl[];
#define s_limit (scm_s_ccl+10)
extern char scm_s_close_port[];
#define s_port_type (scm_s_close_port+6)

/* function prototypes */

SCM * scm_mkarray P((int size, int fillp));
void scm_gc_mark P ((SCM p));
void scm_han_sig P ((void));
void scm_han_alrm P ((void));
void scm_add_to_port_table P((SCM p));
void scm_remove_from_port_table P((SCM p));
void scm_setfileno P((FILE *fs, int fd));
void scm_evict_ports P((int fdes));
char *scm_must_malloc P ((long len, char *what));
char *scm_must_realloc P ((char *where, long olen, long len, char *what));
void scm_must_free P ((char *obj));
long scm_ilength P ((SCM sx));
SCM scm_hash P ((SCM obj, SCM n));
SCM scm_hashv P ((SCM obj, SCM n));
SCM scm_hashq P ((SCM obj, SCM n));
SCM scm_obhash P ((SCM obj));
SCM scm_obunhash P ((SCM obj));
unsigned long scm_strhash P ((unsigned char *str, sizet len, unsigned long n));
unsigned long scm_hasher P ((SCM obj, unsigned long n, sizet d));
SCM scm_repl_driver P ((char *initpath));
SCM scm_lroom P ((SCM args));
long scm_newsmob P ((scm_smobfuns * smob));
long scm_newptob P ((scm_ptobfuns * ptob));
void scm_lthrow P ((SCM cont, SCM val));
void scm_prinport P ((SCM exp, SCM port, char *type));
SCM scm_repl P ((SCM prompt, SCM top_level));
void scm_growth_mon P ((char *obj, long size, char *units));
void scm_gc_start P ((char *what));
void scm_gc_end P ((void));
void scm_heap_report P ((void));
void scm_exit_report P ((void));
void scm_stack_report P ((void));
void scm_iprin1 P ((SCM exp, SCM port, int writing));
void scm_intprint P ((long n, int radix, SCM port));
void scm_iprlist P ((char *hdr, SCM exp, int tlr, SCM port, int writing));
void scm_lputc P ((int c, SCM port));
void scm_lputs P ((char *s, SCM port));
int scm_lfwrite P ((char *ptr, sizet size, sizet nitems, SCM port));
int scm_lgetc P ((SCM port));
void scm_lungetc P ((int c, SCM port));
char *scm_grow_tok_buf P ((SCM tok_buf));
long scm_mode_bits P ((char *modes));
long scm_time_in_msec P ((long x));
SCM scm_my_time P ((void));
SCM scm_your_time P ((void));
void scm_init_iprocs P ((scm_iproc * subra, int type));
void scm_init_scm P ((int iverbose, long init_heap_size));
SCM scm_evstr(char *str);
void scm_ldstr(char *str);
int scm_ldfile P((char *path));
int scm_ldprog P((char *path));
SCM scm_init_extensions P((void));
void scm_ignore_signals P ((void));
void scm_unignore_signals P ((void));
void scm_free_storage P ((void));
void scm_add_feature P ((char *str));
int scm_raprin1 P ((SCM exp, SCM port, int writing));
SCM scm_markcdr P ((SCM ptr));
SCM scm_mark0 P ((SCM ptr));
SCM scm_equal0 P ((SCM ptr1, SCM ptr2));
sizet scm_free0 P ((CELLPTR ptr));
void scm_warn P ((char *str1, char *str2));
void scm_everr P ((SCM exp, SCM env, SCM arg, char *pos, char *s_subr));
void scm_wta P ((SCM arg, char *pos, char *s_subr));
SCM scm_intern P ((char *name, sizet len));
SCM scm_intern0 P ((char *name));
SCM scm_sysintern P ((char *name, SCM val));
SCM scm_sym2vcell P ((SCM sym, SCM thunk, SCM definep));
SCM scm_sym2ovcell P ((SCM sym, SCM obarray));
SCM scm_makstr P ((long len, int slots));
SCM scm_make_subr P ((char *name, int type, SCM (*fcn) ()));
SCM makfromstrs P ((int argc, char **argv));
SCM scm_makfromstr P ((char *src, sizet len, int slots));
SCM scm_closure P ((SCM code, SCM env));
SCM scm_makprom P ((SCM code));
SCM scm_force P ((SCM x));
SCM scm_makarb P ((SCM name));
SCM scm_tryarb P ((SCM arb));
SCM scm_relarb P ((SCM arb));
SCM scm_ceval P ((SCM x, SCM env));
SCM scm_prolixity P ((SCM arg));
SCM scm_gc_for_newcell P ((void));
SCM scm_gc P ((void));
void scm_igc P ((char *what));
SCM scm_tryload P ((SCM filename));
SCM scm_acons P ((SCM w, SCM x, SCM y));
SCM scm_cons2 P ((SCM w, SCM x, SCM y));
SCM scm_listify P ((SCM elt, ...));	/* last arg must be UNDEFINED */
SCM scm_resizuve P ((SCM vect, SCM len));
SCM scm_lnot P ((SCM x));
SCM scm_booleanp P ((SCM obj));
SCM scm_eq P ((SCM x, SCM y));
SCM scm_equal P ((SCM x, SCM y));
SCM scm_consp P ((SCM x));
SCM scm_cons P ((SCM x, SCM y));
SCM scm_nullp P ((SCM x));
SCM scm_setcar P ((SCM pair, SCM value));
SCM scm_setcdr P ((SCM pair, SCM value));
SCM scm_listp P ((SCM x));
SCM scm_list P ((SCM objs));
SCM scm_length P ((SCM x));
SCM scm_append P ((SCM args));
SCM scm_reverse P ((SCM lst));
SCM scm_list_ref P ((SCM lst, SCM k));
SCM scm_memq P ((SCM x, SCM lst));
SCM scm_member P ((SCM x, SCM lst));
SCM scm_memv P ((SCM x, SCM lst));
SCM scm_assq P ((SCM x, SCM alist));
SCM scm_assoc P ((SCM x, SCM alist));
SCM scm_symbolp P ((SCM x));
SCM scm_symbol2string P ((SCM s));
SCM scm_string2symbol P ((SCM s));
SCM scm_numberp P ((SCM x));
SCM scm_exactp P ((SCM x));
SCM scm_inexactp P ((SCM x));
SCM scm_eqp P ((SCM x, SCM y));
SCM scm_lessp P ((SCM x, SCM y));
SCM scm_zerop P ((SCM z));
SCM scm_positivep P ((SCM x));
SCM scm_negativep P ((SCM x));
SCM scm_oddp P ((SCM n));
SCM scm_evenp P ((SCM n));
SCM scm_lmax P ((SCM x, SCM y));
SCM scm_lmin P ((SCM x, SCM y));
SCM scm_sum P ((SCM x, SCM y));
SCM scm_difference P ((SCM x, SCM y));
SCM scm_product P ((SCM x, SCM y));
SCM scm_divide P ((SCM x, SCM y));
SCM scm_lquotient P ((SCM x, SCM y));
SCM scm_absval P ((SCM x));
SCM scm_lremainder P ((SCM x, SCM y));
SCM scm_modulo P ((SCM x, SCM y));
SCM scm_lgcd P ((SCM x, SCM y));
SCM scm_llcm P ((SCM n1, SCM n2));
SCM scm_number2string P ((SCM x, SCM radix));
SCM scm_istring2number P ((char *str, long len, long radix));
SCM scm_string2number P ((SCM str, SCM radix));
SCM scm_istr2flo P ((char *str, long len, long radix));
SCM scm_mkbig P ((sizet nlen, int sign));
SCM scm_mkstrport P((SCM pos, SCM str, long modes, char *caller));
SCM scm_long2big P ((long n));
SCM scm_ulong2big P ((unsigned long n));
SCM scm_big2inum P ((SCM b, sizet l));
sizet scm_iint2str P ((long num, int rad, char *p));
SCM scm_floequal P ((SCM x, SCM y));
SCM uve_equal P ((SCM u, SCM v));
SCM scm_raequal P ((SCM ra0, SCM ra1));
SCM scm_array_equal P ((SCM u, SCM v));
SCM scm_array_fill P ((SCM ra, SCM fill));
SCM scm_array_prot P ((SCM ra));
int scm_bigprint P ((SCM exp, SCM port, int writing));
int scm_floprint P ((SCM sexp, SCM port, int writing));
SCM scm_istr2int P ((char *str, long len, long radix));
SCM scm_istr2bve P ((char *str, long len));
void scm_ipruk P ((char *hdr, SCM ptr, SCM port));
SCM scm_charp P ((SCM x));
SCM scm_char_lessp P ((SCM x, SCM y));
SCM scm_chci_eq P ((SCM x, SCM y));
SCM scm_chci_lessp P ((SCM x, SCM y));
SCM scm_char_alphap P ((SCM chr));
SCM scm_char_nump P ((SCM chr));
SCM scm_char_whitep P ((SCM chr));
SCM scm_char_upperp P ((SCM chr));
SCM scm_char_lowerp P ((SCM chr));
SCM scm_char2int P ((SCM chr));
SCM scm_int2char P ((SCM n));
SCM scm_char_upcase P ((SCM chr));
SCM scm_char_downcase P ((SCM chr));
SCM scm_stringp P ((SCM x));
SCM scm_string P ((SCM chrs));
SCM scm_make_string P ((SCM k, SCM chr));
SCM scm_string2list P ((SCM str));
SCM scm_st_length P ((SCM str));
SCM scm_st_ref P ((SCM str, SCM k));
SCM scm_st_set P ((SCM str, SCM k, SCM chr));
SCM scm_st_equal P ((SCM s1, SCM s2));
SCM scm_stci_equal P ((SCM s1, SCM s2));
SCM scm_st_lessp P ((SCM s1, SCM s2));
SCM scm_stci_lessp P ((SCM s1, SCM s2));
SCM scm_substring P ((SCM str, SCM start, SCM end));
SCM scm_st_append P ((SCM args));
SCM scm_vectorp P ((SCM x));
SCM scm_vector_length P ((SCM v));
SCM scm_vector P ((SCM l));
SCM scm_vector_ref P ((SCM v, SCM k));
SCM scm_vector_set P ((SCM v, SCM k, SCM obj));
SCM scm_make_vector P ((SCM k, SCM fill));
SCM scm_get_lvec_hook P ((SCM vec, int index));
SCM scm_vector2list P ((SCM v));
SCM scm_for_each P ((SCM proc, SCM arg1, SCM args));
SCM scm_procedurep P ((SCM obj));
SCM scm_apply P ((SCM proc, SCM arg1, SCM args));
SCM scm_map P ((SCM proc, SCM arg1, SCM args));
SCM scm_make_cont P ((void));
SCM scm_copytree P ((SCM obj));
SCM scm_eval P ((SCM obj));
SCM scm_neval P ((SCM obj));
SCM scm_input_portp P ((SCM x));
SCM scm_output_portp P ((SCM x));
SCM scm_cur_input_port P ((void));
SCM scm_cur_output_port P ((void));
SCM i_setbuf0 P ((SCM port));
SCM scm_open_file P ((SCM filename, SCM modes));
SCM scm_open_pipe P ((SCM pipestr, SCM modes));
SCM scm_close_port P ((SCM port));
SCM scm_lread P ((SCM port, SCM casep));
SCM scm_read_char P ((SCM port));
SCM scm_peek_char P ((SCM port));
SCM scm_eof_objectp P ((SCM x));
SCM scm_lwrite P ((SCM obj, SCM port));
SCM scm_display P ((SCM obj, SCM port));
SCM scm_newline P ((SCM port));
SCM scm_l_alarm P((SCM));
SCM scm_l_pause P((void));
SCM scm_l_sleep P((SCM));
SCM scm_l_raise P((SCM));
SCM scm_lticks P((SCM));
SCM scm_write_char P ((SCM chr, SCM port));
SCM scm_file_position P ((SCM port));
SCM scm_file_set_position P ((SCM port, SCM pos, SCM whence));
SCM scm_lgetenv P ((SCM nam));
SCM scm_prog_args P ((void));
SCM scm_makacro P ((SCM code));
SCM scm_makmacro P ((SCM code));
SCM scm_makmmacro P ((SCM code));
void poll_routine P ((void));
void scm_tick_signal P ((void));
void stack_check P ((void));
SCM scm_make_ra P ((int ndim));
SCM makflo P ((float x));
SCM scm_arrayp P ((SCM v, SCM prot));
SCM scm_array_contents P ((SCM ra, SCM strict));
SCM scm_aset P ((SCM v, SCM obj, SCM args));
SCM scm_aref P ((SCM v, SCM args));
SCM scm_cvref P ((SCM v, sizet pos, SCM last));
SCM scm_list2ura P ((SCM ndim, SCM prot, SCM lst));
SCM scm_quit P ((SCM n));
SCM scm_abrt P ((void));
void scm_add_final P ((void (*final) (void)));
void scm_dowinds P ((SCM to, long delta));
SCM scm_makcclo P ((SCM proc, long len));
SCM scm_make_uve P ((long k, SCM prot));
SCM scm_ra2contig P ((SCM ra, int copy));
SCM scm_array_copy P ((SCM src, SCM dst));
SCM scm_long2num P((long n));
SCM scm_ulong2num P ((unsigned long n));
unsigned long scm_num2ulong P ((SCM num, char *pos, char *s_caller));
long scm_num2long P((SCM num, char *pos, char *s_caller));

#ifdef FLOATS
SCM scm_makdbl P ((double x, double y));
SCM scm_dbl2big P ((double d));
double scm_big2dbl P ((SCM b));
double scm_lasinh P((double x));
double scm_lacosh P((double x));
double scm_latanh P((double x));
double scm_ltrunc P((double x));
double scm_round P((double x));
double scm_floident P((double x));
#endif

#ifdef BIGDIG
void longdigs P ((long x, BIGDIG digs[DIGSPERLONG]));
SCM scm_adjbig P ((SCM b, sizet nlen));
SCM scm_normbig P ((SCM b));
SCM scm_copybig P ((SCM b, int sign));
SCM scm_addbig P ((BIGDIG * x, sizet nx, int xsgn, SCM bigy, int sgny));
SCM scm_mulbig P ((BIGDIG * x, sizet nx, BIGDIG * y, sizet ny, int sgn));
unsigned int scm_divbigdig P ((BIGDIG * ds, sizet h, BIGDIG div));
SCM scm_divbigint P ((SCM x, long z, int sgn, int mode));
SCM scm_divbigbig P ((BIGDIG * x, sizet nx, BIGDIG * y, sizet ny, int sgn,
		      int modes));
long scm_pseudolong P ((long x));
#endif
int scm_bigcomp P ((SCM x, SCM y));
SCM scm_bigequal P ((SCM x, SCM y));

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

#define ARGn 0
#define ARG1 1
#define ARG2 2
#define ARG3 3
#define ARG4 4
#define ARG5 5
#define ARG6 6
#define ARG7 7
#define ARGERR(X) ((X) < WNA ? (char *)(X) : "wrong type argument")

/* Following must match entry indexes in scm_errmsgs[].
 * Also, WNA must follow the last ARGn in sequence.
 */
#define WNA 8
#define OVFLOW 9
#define OUTOFRANGE 10
#define NALLOC 11
#define EXIT 12
#define HUP_SIGNAL 13
#define INT_SIGNAL 14
#define FPE_SIGNAL 15
#define BUS_SIGNAL 16
#define SEGV_SIGNAL 17
#define ALRM_SIGNAL 18

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

#define NEWCELL(_into) {if (IMP(scm_freelist)) _into = scm_gc_for_newcell();\
else {_into = scm_freelist;scm_freelist = CDR(scm_freelist);++scm_cells_allocated;}}



struct heap_seg_data
{
  CELLPTR bounds[2];		/* lower and upper */
  SCM *freelistp;		/* the value of this may be shared */
  int ncells;			/* per object in this segment */
  int (*valid) P ((CELLPTR, struct heap_seg_data *));
};

extern struct heap_seg_data *scm_heap_table;
extern int scm_n_heap_segs;

#define CONSTANT_Unused0			0
#define CONSTANT_Asciz				1
#define CONSTANT_Unused1			2
#define CONSTANT_Integer			3
#define CONSTANT_Float				4
#define CONSTANT_Long				5
#define CONSTANT_Double				6
#define CONSTANT_Class				7
#define CONSTANT_String				8
#define CONSTANT_Fieldref			9
#define CONSTANT_MethodRef			10
#define CONSTANT_InterfaceMethodref		11
#define CONSTANT_NameandType			12
#define n_constant_types			13

extern SCM constant_type_names[];
