s9.h

/*
 * Scheme 9 from Empty Space
 * By Nils M Holm, 2007-2012
 * Placed in the Public Domain
 */

/*
 * Ugly prelude to figure out if
 * we are compiling on a Un*x system.
 */

#ifdef __NetBSD__
 #ifndef unix
  #define unix
 #endif
#endif

#ifdef __unix
 #ifndef unix
  #define unix
 #endif
#endif

#ifdef __linux
 #ifndef unix
  #define unix
 #endif
#endif

#ifndef unix
 #ifndef plan9
  #error "Either 'unix' or 'plan9' must be #defined."
 #endif
#endif

#ifdef unix
 #ifndef _BSD_SOURCE
  #define _BSD_SOURCE
 #endif
 #ifndef __FreeBSD__
  #ifndef __NetBSD__
   #ifndef _POSIX_SOURCE
    #define _POSIX_SOURCE
    #define _POSIX_C_SOURCE 200112L
   #endif
   #ifndef _XOPEN_SOURCE
    #define _XOPEN_SOURCE 500
   #endif
  #endif
 #endif
#endif

#ifdef plan9
 #include <u.h>
 #include <libc.h>
 #include <stdio.h>
 #include <ctype.h>
 #define NO_SIGNALS
 #define signal(sig, fn)
 #define exit(x) exits((x)? "error": NULL)
 #define ptrdiff_t int
#endif

#ifdef unix
 #include <stdlib.h>
 #include <stddef.h>
 #include <stdio.h>
 #include <string.h>
 #include <ctype.h>
 #ifdef NO_SIGNALS
  #define signal(sig, fn)
 #else
  #include <signal.h>
  #ifndef SIGQUIT
   /* MinGW does not define SIGQUIT */
   #define SIGQUIT SIGINT
  #endif
 #endif
#endif

/*
 * Tell later MSC compilers to let us use the standard CLIB API.
 * Blake McBride < b l a k e  at  m c b r i d e . n a m e >
 */

#ifdef _MSC_VER
 #if _MSC_VER > 1200
  #ifndef _CRT_SECURE_NO_DEPRECATE
   #define _CRT_SECURE_NO_DEPRECATE
  #endif
 #endif
 #ifndef _POSIX_
  #define _POSIX_
 #endif
#endif

#ifndef DEFAULT_LIBRARY_PATH
 #define DEFAULT_LIBRARY_PATH \
		"."				\
		":lib"				\
		":ext"				\
		":contrib"			\
		":~/.s9fes"			\
		":/usr/local/share/s9fes"
#endif

#ifndef INITIAL_SEGMENT_SIZE
 #define INITIAL_SEGMENT_SIZE	32768
#endif

#define TOKEN_LENGTH		1024
#define MAX_PORTS		32
#define MAX_IO_DEPTH		65536	/* Reduce on 16-bit systems! */
#define HASH_THRESHOLD		5
#define MAX_CALL_TRACE		100

/* Default memory limit in K-nodes, 0 = none */
#define DEFAULT_LIMIT_KN	12392

/* A "cell" must be large enough to hold a pointer */
#define cell	ptrdiff_t

/* 64-bit emulation on 32-bit system; DO NOT USE! */
#ifdef EMULATE_64
 #undef BITS_PER_WORD_32
 #define BITS_PER_WORD_64
 #undef cell
 #define cell           long long
 #define labs(x)        llabs(x)
 #define atol(x)        atoll(x)
#endif

/* Pick one ... */
/* #define BITS_PER_WORD_64 */
/* #define BITS_PER_WORD_32 */
/* #define BITS_PER_WORD_16 */

/* ... or assume a reasonable default */
#ifndef BITS_PER_WORD_16
 #ifndef BITS_PER_WORD_32
  #ifndef BITS_PER_WORD_64
   #define BITS_PER_WORD_32
  #endif
 #endif
#endif

/*
 * N-bit arithmetics require sizeof(cell) >= N/8.
 * When MANTISSA_SIZE (below) gets more than 60 places, you
 * will have to supply a better value for PI in "s9-real.scm".
 */

#ifdef BITS_PER_WORD_64
 #define DIGITS_PER_WORD	18
 #ifdef EMULATE_64
  #define INT_SEG_LIMIT		1000000000000000000LL
 #else
  #define INT_SEG_LIMIT		1000000000000000000L
 #endif
 #define MANTISSA_SEGMENTS	1
#else
 #ifdef BITS_PER_WORD_32
  #define DIGITS_PER_WORD	9
  #define INT_SEG_LIMIT		1000000000L
  #define MANTISSA_SEGMENTS	2
 #else
  #ifdef BITS_PER_WORD_16
   #define DIGITS_PER_WORD	4
   #define INT_SEG_LIMIT	10000
   #define MANTISSA_SEGMENTS	3
  #else
   #error "BITS_PER_WORD_* undefined (this should not happen)"
  #endif
 #endif
#endif

/* Mantissa sizes differ among systems */
#define MANTISSA_SIZE   (MANTISSA_SEGMENTS * DIGITS_PER_WORD)

/*
 * Node tags
 */

#define ATOM_TAG	0x01	/* Atom, Car = type, CDR = next */
#define MARK_TAG	0x02	/* Mark */
#define STATE_TAG	0x04	/* State */
#define VECTOR_TAG	0x08	/* Vector, Car = type, CDR = content */
#define PORT_TAG	0x10	/* Atom is an I/O port (with ATOM_TAG) */
#define USED_TAG	0x20	/* Port: used flag */
#define LOCK_TAG	0x40	/* Port: locked (do not close) */
#define CONST_TAG	0x80	/* Node is immutable */

/*
 * Evaluator states
 */

enum EVAL_STATES {
	EV_ATOM,	/* Evaluating atom */
	EV_ARGS,	/* Evaluating argument list */
	EV_BETA,	/* Evaluating procedure body */
	EV_IF_PRED,	/* Evaluating predicate of IF */
	EV_SET_VAL,	/* Evaluating value of SET! and DEFINE */
	EV_MACRO,	/* Evaluating value of DEFINE-SYNTAX */
	EV_BEGIN,	/* Evaluating expressions of BEGIN */
	EV_AND,		/* Evaluating arguments of AND */
	EV_OR,		/* Evaluating arguments of OR */
	EV_COND		/* Evaluating clauses of COND */
};

/*
 * Binding structure
 */

#define make_binding(v, a)	(cons((v), (a)))
#define binding_box(x)		(x)
#define binding_value(x)	(cdr(x))
#define box_value(x)		(cdr(x))

/*
 * Special objects
 */

#define special_value_p(x)	((x) < 0)
#define NIL			(-1)
#define TRUE			(-2)
#define FALSE			(-3)
#define END_OF_FILE		(-4)
#define UNDEFINED		(-5)
#define UNSPECIFIC		(-6)
#define NAN			(-7)
#define DOT			(-8)
#define RPAREN			(-9)
#define RBRACK			(-10)
#define NOEXPR			(-11)

/*
 * Types
 */

#define T_NONE			(-20)
#define T_BOOLEAN		(-21)
#define T_CHAR			(-22)
#define T_INPUT_PORT		(-23)
#define T_INTEGER		(-24)
#define T_OUTPUT_PORT		(-25)
#define T_PAIR			(-26)
#define T_PAIR_OR_NIL		(-27)
#define T_PRIMITIVE		(-28)
#define T_PROCEDURE		(-29)
#define T_REAL			(-30)
#define T_STRING		(-31)
#define T_SYMBOL		(-32)
#define T_SYNTAX		(-33)
#define T_VECTOR		(-34)
#define T_CONTINUATION		(-35)

/*
 * Short cuts for primitive procedure definitions
 */

#define BOL T_BOOLEAN
#define CHR T_CHAR
#define INP T_INPUT_PORT
#define INT T_INTEGER
#define LST T_PAIR_OR_NIL
#define OUP T_OUTPUT_PORT
#define PAI T_PAIR
#define PRC T_PROCEDURE
#define REA T_REAL
#define STR T_STRING
#define SYM T_SYMBOL
#define VEC T_VECTOR
#define ___ T_NONE

struct Primitive_procedure {
	char	*name;
	cell	(*handler)(cell expr);
	int	min_args;
	int	max_args;	/* -1 = variadic */
	int	arg_types[3];
};

#define PRIM    struct Primitive_procedure

/*
 * Globals
 */

#ifndef EXTERN
 #define EXTERN extern
#endif

EXTERN int	Cons_segment_size,
		Vec_segment_size;
EXTERN int	Cons_pool_size,
		Vec_pool_size;

EXTERN cell	*Car,
		*Cdr;
EXTERN char	*Tag;

EXTERN cell	*Vectors;

EXTERN cell	Free_list;
EXTERN cell	Free_vecs;

EXTERN cell	Stack,
		Stack_bottom;
EXTERN cell	State_stack;
EXTERN cell	Tmp_car,
		Tmp_cdr,
		Tmp;
EXTERN cell	Symbols;
EXTERN cell	Program;
EXTERN cell	Environment;
EXTERN cell	Acc;
EXTERN PRIM	*Apply_magic, *Call_magic;
EXTERN cell	New;

EXTERN int	Level;
EXTERN int	Load_level;
EXTERN int	Displaying;

EXTERN cell     Called_procedures[MAX_CALL_TRACE];
EXTERN int      Proc_ptr, Proc_max;
EXTERN cell     File_list;
EXTERN int      Line_no;
EXTERN int      Printer_count, Printer_limit;

EXTERN cell     Trace_list;

EXTERN FILE	*Ports[MAX_PORTS];
EXTERN char	Port_flags[MAX_PORTS];
EXTERN int	Input_port,
		Output_port,
		Error_port;

EXTERN char     **Command_line;
EXTERN long     Memory_limit_kn;
EXTERN int      Quiet_mode;

EXTERN volatile int     Error_flag;

/* Short cuts for accessing predefined symbols */
EXTERN cell	S_arrow, S_else, S_extensions, S_latest,
		S_library_path, S_loading, S_quasiquote,
		S_quote, S_unquote, S_unquote_splicing;
EXTERN cell	S_and, S_begin, S_cond, S_define,
		S_define_syntax, S_if, S_lambda, S_or,
		S_set_b;

/*
 * I/O
 */

#define nl()            pr("\n")
#define reject(c)       ungetc(c, Ports[Input_port])
#define read_c()        getc(Ports[Input_port])
#define read_c_ci()     tolower(read_c())

/*
 * Access to fields of atoms
 */

#define string(n)       ((char *) &Vectors[Cdr[n]])
#define string_len(n)   (Vectors[Cdr[n] - 1])
#define symbol_name(n)  (string(n))
#define symbol_len(n)   (string_len(n))
#define vector(n)       (&Vectors[Cdr[n]])
#define vector_link(n)  (Vectors[Cdr[n] - 3])
#define vector_index(n) (Vectors[Cdr[n] - 2])
#define vector_size(k)  (((k) + sizeof(cell)-1) / sizeof(cell) + 3)
#define vector_len(n)   (vector_size(string_len(n)) - 3)
#define port_no(n)      (cadr(n))
#define char_value(n)   (cadr(n))

/*
 * Internal vector representation
 */

#define RAW_VECTOR_LINK         0
#define RAW_VECTOR_INDEX        1
#define RAW_VECTOR_SIZE         2
#define RAW_VECTOR_DATA         3

/*
 * Flags and structure of real numbers
 */

#define _real_flags(x)          (cadr(x))
#define _real_exponent(x)       (caddr(x))
#define _real_mantissa(x)       (cdddr(x))

#define REAL_NEGATIVE   0x01

#define _real_negative_flag(x)  (_real_flags(x) & REAL_NEGATIVE)

/*
 * Nested lists
 */

#define car(x)          (Car[x])
#define cdr(x)          (Cdr[x])
#define caar(x)         (Car[Car[x]])
#define cadr(x)         (Car[Cdr[x]])
#define cdar(x)         (Cdr[Car[x]])
#define cddr(x)         (Cdr[Cdr[x]])
#define caaar(x)        (Car[Car[Car[x]]])
#define caadr(x)        (Car[Car[Cdr[x]]])
#define cadar(x)        (Car[Cdr[Car[x]]])
#define caddr(x)        (Car[Cdr[Cdr[x]]])
#define cdaar(x)        (Cdr[Car[Car[x]]])
#define cdadr(x)        (Cdr[Car[Cdr[x]]])
#define cddar(x)        (Cdr[Cdr[Car[x]]])
#define cdddr(x)        (Cdr[Cdr[Cdr[x]]])
#define caaddr(x)       (Car[Car[Cdr[Cdr[x]]]])
#define caddar(x)       (Car[Cdr[Cdr[Car[x]]]])
#define cadadr(x)       (Car[Cdr[Car[Cdr[x]]]])
#define cadddr(x)       (Car[Cdr[Cdr[Cdr[x]]]])
#define cddadr(x)       (Cdr[Cdr[Car[Cdr[x]]]])
#define cdddar(x)       (Cdr[Cdr[Cdr[Car[x]]]])
#define cddddr(x)       (Cdr[Cdr[Cdr[Cdr[x]]]])

/*
 * Type predicates
 */

#define eof_p(n)	((n) == END_OF_FILE)
#define undefined_p(n)	((n) == UNDEFINED)
#define unspecific_p(n)	((n) == UNSPECIFIC)

#define boolean_p(n)	((n) == TRUE || (n) == FALSE)

#define constant_p(n)	(!special_value_p(n) && (Tag[n] & CONST_TAG))

#define integer_p(n) \
	(!special_value_p(n) && (Tag[n] & ATOM_TAG) && Car[n] == T_INTEGER)
#define number_p(n) \
	(!special_value_p(n) && (Tag[n] & ATOM_TAG) && \
		(Car[n] == T_REAL || Car[n] == T_INTEGER))
#define primitive_p(n) \
	(!special_value_p(n) && (Tag[n] & ATOM_TAG) && Car[n] == T_PRIMITIVE)
#define procedure_p(n) \
	(!special_value_p(n) && (Tag[n] & ATOM_TAG) && Car[n] == T_PROCEDURE)
#define continuation_p(n) \
	(!special_value_p(n) && (Tag[n] & ATOM_TAG) && \
		Car[n] == T_CONTINUATION)
#define real_p(n) \
	(!special_value_p(n) && (Tag[n] & ATOM_TAG) && Car[n] == T_REAL)
#define special_p(n)	((n) == S_quote	  || \
			 (n) == S_begin	  || \
			 (n) == S_if	  || \
			 (n) == S_cond	  || \
			 (n) == S_and	  || \
			 (n) == S_or	  || \
			 (n) == S_lambda  || \
			 (n) == S_set_b	  || \
			 (n) == S_define  || \
			 (n) == S_define_syntax)
#define char_p(n) \
	(!special_value_p(n) && (Tag[n] & ATOM_TAG) && Car[n] == T_CHAR)
#define syntax_p(n) \
	(!special_value_p(n) && (Tag[n] & ATOM_TAG) && Car[n] == T_SYNTAX)
#define input_port_p(n) \
	(!special_value_p(n) && (Tag[n] & ATOM_TAG) && (Tag[n] & PORT_TAG) \
	 && Car[n] == T_INPUT_PORT)
#define output_port_p(n) \
	(!special_value_p(n) && (Tag[n] & ATOM_TAG) && (Tag[n] & PORT_TAG) \
	 && Car[n] == T_OUTPUT_PORT)

#define symbol_p(n) \
	(!special_value_p(n) && (Tag[n] & VECTOR_TAG) && Car[n] == T_SYMBOL)
#define vector_p(n) \
	(!special_value_p(n) && (Tag[n] & VECTOR_TAG) && Car[n] == T_VECTOR)
#define string_p(n) \
	(!special_value_p(n) && (Tag[n] & VECTOR_TAG) && Car[n] == T_STRING)

#define atom_p(n) \
	(special_value_p(n) || (Tag[n] & ATOM_TAG) || (Tag[n] & VECTOR_TAG))

#define auto_quoting_p(n) atom_p(n)

#define pair_p(x) (!atom_p(x))

/*
 * Rib structure
 */

#define rib_args(x)     (car(x))
#define rib_append(x)   (cadr(x))
#define rib_result(x)   (caddr(x))
#define rib_source(x)   (cdddr(x))

/*
 * Allocators
 */

#define cons(pa, pd)            cons3((pa), (pd), 0)

#define new_atom(pa, pd)        cons3((pa), (pd), ATOM_TAG)

#define save(n)         (Stack = cons((n), Stack))
#define save_state(v)   (State_stack = cons3((v), State_stack, ATOM_TAG))

/*
 * Bignum arithmitcs
 */

#define _bignum_negative_p(a)	((cadr(a)) < 0)
#define _bignum_zero_p(a)	((cadr(a) == 0) && (cddr(a)) == NIL)
#define _bignum_positive_p(a) \
		(!_bignum_negative_p(a) && !_bignum_zero_p(a))

/*
 * Real-number arithmetics
 */

#define _real_zero_p(x) \
	(car(_real_mantissa(x)) == 0 && cdr(_real_mantissa(x)) == NIL)

#define _real_negative_p(x) \
	(_real_negative_flag(x) && !_real_zero_p(x))

#define _real_positive_p(x) \
	(!_real_negative_flag(x) && !_real_zero_p(x))

#define _real_negate(a) \
	make_real(_real_flags(a) & REAL_NEGATIVE?	\
			_real_flags(a) & ~REAL_NEGATIVE: \
			_real_flags(a) |  REAL_NEGATIVE, \
		_real_exponent(a), _real_mantissa(a))

/*
 * Prototypes
 */

void	add_primitives(char *name, PRIM *p);
cell	symbol_ref(char *s);
cell	cons3(cell pcar, cell pcdr, int ptag);
int	new_port(void);
char	*copy_string(char *s);
cell	error(char *msg, cell expr);
void	fatal(char *msg);
cell	integer_value(char *src, cell x);
int	length(cell x);
cell	make_char(int c);
cell	make_integer(cell i);
cell	make_port(int portno, cell type);
cell	make_string(char *s, int k);
cell	unsave(int k);