335 lines
8.6 KiB
C
335 lines
8.6 KiB
C
/* The Scheme object representation, and a few other important
|
|
* data types.
|
|
*/
|
|
|
|
#include <stdint.h>
|
|
#include <malloc.h>
|
|
|
|
typedef struct {
|
|
int64_t data;
|
|
int tag;
|
|
} Object;
|
|
|
|
#define FIXBITS (8 * sizeof(int))
|
|
#define SIGNBIT ((unsigned)1 << (FIXBITS-1))
|
|
#define CONSTBIT 1
|
|
#define TYPEBITS (8 * sizeof(int) - 1)
|
|
#define MAX_TYPE ((1 << TYPEBITS) - 1)
|
|
|
|
#define UFIXNUM_FITS(i) (((i) & SIGNBIT) == 0)
|
|
#define FIXNUM_FITS(i) 1
|
|
|
|
#define TYPE(x) ((x).tag >> 1)
|
|
|
|
#define FIXNUM(x) ((int)(x).data)
|
|
#define CHAR(x) ((int)(x).data)
|
|
|
|
#define POINTER(x) ((void *)(ptrdiff_t)(x).data)
|
|
#define SETPOINTER(x,p) ((x).data = (ptrdiff_t)(void *)(p))
|
|
#define SET(x,t,p) ((x).tag = (int)t << 1, (x).data = (p))
|
|
|
|
#define ISCONST(x) ((x).tag & CONSTBIT)
|
|
#define SETCONST(x) ((x).tag |= CONSTBIT)
|
|
|
|
#define EQ(x,y) ((x).data == (y).data && (x).tag == (y).tag)
|
|
|
|
/* GC related macros:
|
|
*/
|
|
#define WAS_FORWARDED(obj) (TYPE(*(Object *)POINTER(obj)) == T_Broken_Heart)
|
|
#define UPDATE_OBJ(obj) SETPOINTER(obj, POINTER(*(Object *)POINTER(obj)))
|
|
|
|
#ifdef GENERATIONAL_GC
|
|
|
|
typedef int gcspace_t; /* type for space and type arrays */
|
|
typedef unsigned long int gcptr_t; /* type for pointers */
|
|
typedef unsigned long int pageno_t; /* type for page numbers */
|
|
typedef unsigned long int addrarith_t; /* type for address arithmetic */
|
|
|
|
extern gcspace_t *space;
|
|
extern gcspace_t current_space;
|
|
C_LINKAGE_BEGIN
|
|
extern int Visit P_((Object*)); /* required for REVIVE_OBJ below */
|
|
C_LINKAGE_END
|
|
|
|
# ifdef ARRAY_BROKEN
|
|
extern pageno_t pagebase;
|
|
# else
|
|
# define pagebase ((pageno_t)0)
|
|
# endif
|
|
|
|
# define PAGEBYTES 512
|
|
# define PAGE_TO_OBJ(p) ((Object *) (((p) + pagebase) * PAGEBYTES))
|
|
# define OBJ_TO_PAGE(p) ((((gcptr_t)POINTER(p)) / PAGEBYTES) - pagebase)
|
|
# define STABLE(x) ((~space[(x)]) & 1)
|
|
# define MAKEOBJ(o,t,p) (SET(o, t, p))
|
|
# define IS_ALIVE(obj) ((WAS_FORWARDED(obj)) || \
|
|
(STABLE(OBJ_TO_PAGE(obj))) || \
|
|
(space[OBJ_TO_PAGE(obj)] == current_space))
|
|
# define REVIVE_OBJ(obj) Visit (&obj);
|
|
#else
|
|
C_LINKAGE_BEGIN
|
|
extern int Visit P_((Object*)); /* required in heap.c */
|
|
C_LINKAGE_END
|
|
# define IS_ALIVE(obj) WAS_FORWARDED(obj)
|
|
# define REVIVE_OBJ(obj)
|
|
#endif
|
|
|
|
/* Fixed types. Cannot use enum, because the set of types is extensible:
|
|
*/
|
|
#define T_Fixnum 0 /* Must be 0 */
|
|
#define T_Bignum 1
|
|
#define T_Flonum 2
|
|
#define T_Null 3 /* empty list */
|
|
#define T_Boolean 4 /* #t (1) and #f (0) */
|
|
#define T_Unbound 5 /* only used internally */
|
|
#define T_Special 6 /* only used internally */
|
|
#define T_Character 7
|
|
#define T_Symbol 8
|
|
#define T_Pair 9
|
|
#define T_Environment 10 /* A pair */
|
|
#define T_String 11
|
|
#define T_Vector 12
|
|
#define T_Primitive 13 /* Primitive procedure */
|
|
#define T_Compound 14 /* Compound procedure */
|
|
#define T_Control_Point 15
|
|
#define T_Promise 16 /* Result of (delay expression) */
|
|
#define T_Port 17
|
|
#define T_End_Of_File 18
|
|
#define T_Autoload 19
|
|
#define T_Macro 20
|
|
#define T_Broken_Heart 21 /* only used internally */
|
|
#ifdef GENERATIONAL_GC
|
|
# define T_Align_8Byte 22 /* only used internally */
|
|
# define T_Freespace 23 /* only used internally */
|
|
#endif
|
|
|
|
#define BIGNUM(x) ((struct S_Bignum *)POINTER(x))
|
|
#define FLONUM(x) ((struct S_Flonum *)POINTER(x))
|
|
#define STRING(x) ((struct S_String *)POINTER(x))
|
|
#define VECTOR(x) ((struct S_Vector *)POINTER(x))
|
|
#define SYMBOL(x) ((struct S_Symbol *)POINTER(x))
|
|
#define PAIR(x) ((struct S_Pair *)POINTER(x))
|
|
#define PRIM(x) ((struct S_Primitive *)POINTER(x))
|
|
#define COMPOUND(x) ((struct S_Compound *)POINTER(x))
|
|
#define CONTROL(x) ((struct S_Control *)POINTER(x))
|
|
#define PROMISE(x) ((struct S_Promise *)POINTER(x))
|
|
#define PORT(x) ((struct S_Port *)POINTER(x))
|
|
#define AUTOLOAD(x) ((struct S_Autoload *)POINTER(x))
|
|
#define MACRO(x) ((struct S_Macro *)POINTER(x))
|
|
|
|
typedef unsigned short gran_t; /* Granularity of bignums */
|
|
|
|
struct S_Bignum {
|
|
Object minusp;
|
|
unsigned int size; /* Number of ushorts allocated */
|
|
unsigned int usize; /* Number of ushorts actually used */
|
|
gran_t data[1]; /* Data, lsw first */
|
|
};
|
|
|
|
struct S_Flonum {
|
|
Object tag; /* Each S_Foo must start with an Object */
|
|
double val;
|
|
};
|
|
|
|
struct S_Symbol {
|
|
Object value;
|
|
Object next;
|
|
Object name; /* A string */
|
|
Object plist;
|
|
};
|
|
|
|
struct S_Pair {
|
|
Object car, cdr;
|
|
};
|
|
|
|
struct S_String {
|
|
Object tag;
|
|
int size;
|
|
char data[1];
|
|
};
|
|
|
|
struct S_Vector {
|
|
Object tag;
|
|
int size;
|
|
Object data[1];
|
|
};
|
|
|
|
enum discipline { EVAL, NOEVAL, VARARGS };
|
|
struct S_Primitive {
|
|
Object tag;
|
|
Object (*fun) P_((ELLIPSIS));
|
|
const char *name;
|
|
int minargs;
|
|
int maxargs; /* Or MANY */
|
|
enum discipline disc;
|
|
};
|
|
#define MANY 100
|
|
|
|
struct S_Compound {
|
|
Object closure; /* (lambda (args) form ...) */
|
|
Object env; /* Procedure's environment */
|
|
int min_args, max_args;
|
|
int numforms;
|
|
Object name;
|
|
};
|
|
|
|
typedef struct wind {
|
|
struct wind *next, *prev;
|
|
Object inout; /* Pair of thunks */
|
|
} WIND;
|
|
|
|
typedef struct funct {
|
|
struct funct *next;
|
|
char *name;
|
|
void (*func) P_((void));
|
|
} FUNCT;
|
|
|
|
typedef struct gcnode {
|
|
struct gcnode *next;
|
|
int gclen;
|
|
Object *gcobj;
|
|
} GCNODE;
|
|
|
|
typedef struct mem_node {
|
|
struct mem_node *next;
|
|
unsigned int len;
|
|
unsigned long int refcnt;
|
|
} MEM_NODE;
|
|
|
|
#if defined(vax) || defined(__vax__)
|
|
typedef int jmp_buf[17];
|
|
#else
|
|
# include <setjmp.h>
|
|
#endif
|
|
|
|
struct S_Control {
|
|
Object env;
|
|
GCNODE *gclist;
|
|
MEM_NODE *memlist;
|
|
Object memsave; /* string */
|
|
Object gcsave; /* vector */
|
|
WIND *firstwind, *lastwind;
|
|
int tailcall;
|
|
ptrdiff_t delta;
|
|
#ifdef GENERATIONAL_GC
|
|
int reloc;
|
|
#endif
|
|
jmp_buf j;
|
|
int size;
|
|
unsigned long int intrlevel;
|
|
char stack[1]; /* must be word aligned */
|
|
};
|
|
|
|
struct S_Promise {
|
|
Object env;
|
|
Object thunk;
|
|
int done;
|
|
};
|
|
|
|
struct S_Port {
|
|
Object name; /* string */
|
|
short flags;
|
|
char unread;
|
|
int ptr;
|
|
FILE *file;
|
|
unsigned int lno;
|
|
int (*closefun) P_((FILE*));
|
|
};
|
|
#define P_OPEN 1 /* flags */
|
|
#define P_INPUT 2
|
|
#define P_STRING 4
|
|
#define P_UNREAD 8
|
|
#define P_BIDIR 16
|
|
|
|
#define IS_INPUT(port) (PORT(port)->flags & (P_INPUT|P_BIDIR))
|
|
#define IS_OUTPUT(port) ((PORT(port)->flags & (P_INPUT|P_BIDIR)) != P_INPUT)
|
|
|
|
struct S_Autoload {
|
|
Object files;
|
|
Object env;
|
|
};
|
|
|
|
struct S_Macro {
|
|
Object body;
|
|
int min_args, max_args;
|
|
Object name;
|
|
};
|
|
|
|
|
|
/* "size" is called with one object and returns the size of the object.
|
|
* If "size" is NOFUNC, then "const_size" is taken instead.
|
|
* "eqv" and "equal" are called with two objects and return 0 or 1.
|
|
* NOFUNC may be passed instead (then eqv and equal always return #f).
|
|
* "print" is called with an object, a port, a flag indicating whether
|
|
* the object is to be printed "raw" (a la display), the print-depth,
|
|
* and the print-length.
|
|
* "visit" is called with a pointer to an object and a function.
|
|
* For each component of the object, the function must be called with
|
|
* a pointer to the component. NOFUNC may be supplied.
|
|
*/
|
|
typedef struct {
|
|
int haspointer;
|
|
const char *name;
|
|
int (*size) P_((Object));
|
|
int const_size;
|
|
int (*eqv) P_((Object, Object));
|
|
int (*equal) P_((Object, Object));
|
|
int (*print) P_((Object, Object, int, int, int));
|
|
int (*visit) P_((Object*, int (*)(Object*)));
|
|
} TYPEDESCR;
|
|
|
|
#ifdef ELK_USE_PROTOTYPES
|
|
# define NOFUNC 0
|
|
#else
|
|
# define NOFUNC ((int (*)())0)
|
|
#endif
|
|
|
|
|
|
typedef struct sym {
|
|
struct sym *next;
|
|
char *name;
|
|
unsigned long int value;
|
|
} SYM;
|
|
|
|
typedef struct {
|
|
SYM *first;
|
|
char *strings;
|
|
} SYMTAB;
|
|
|
|
typedef struct {
|
|
char *name;
|
|
int type;
|
|
} SYMPREFIX;
|
|
|
|
#define PR_EXTENSION 0 /* Elk extension initializers/finalizers */
|
|
#define PR_CONSTRUCTOR 1 /* C++ static constructors/destructors */
|
|
|
|
|
|
/* PFO, GENERIC, and MATCHFUN exist for backwards compatibility
|
|
*/
|
|
typedef Object (*PFO) P_((Object));
|
|
typedef int (*MATCHFUN) P_((ELLIPSIS));
|
|
#define GENERIC char*
|
|
|
|
typedef struct weak_node {
|
|
struct weak_node *next;
|
|
Object obj;
|
|
PFO term;
|
|
GENERIC group;
|
|
char flags;
|
|
} WEAK_NODE;
|
|
|
|
/* flags */
|
|
#define WK_LEADER 1
|
|
|
|
|
|
typedef struct {
|
|
char *name;
|
|
unsigned long int val;
|
|
} SYMDESCR;
|
|
|
|
|
|
/* Function that can be registered as a reader by Define_Reader():
|
|
*/
|
|
typedef Object (*READFUN) P_((Object, int, int));
|