286 lines
11 KiB
C++
286 lines
11 KiB
C++
/* Scheme In One Defun, but in C this time.
|
|
|
|
* COPYRIGHT (c) 1988-1994 BY *
|
|
* PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. *
|
|
* See the source file SLIB.C for more information. *
|
|
|
|
*/
|
|
|
|
/*************************************************************************/
|
|
/* Author : Alan W Black */
|
|
/* Date : March 1999 */
|
|
/*-----------------------------------------------------------------------*/
|
|
/* */
|
|
/* Struct and macro definitions for SIOD */
|
|
/* */
|
|
/*=======================================================================*/
|
|
#ifndef __EST_SIOD_DEFS_H__
|
|
#define __EST_SIOD_DEFS_H__
|
|
|
|
/* This states the default heap size is effective unset */
|
|
/* The size if no heap is specified by a command argument, the */
|
|
/* value of the environment variable SIODHEAPSIZE will be used */
|
|
/* otherwise ACTUAL_DEFAULT_HEAP_SIZE is used. This is *not* */
|
|
/* documented because environment variables can cause so many */
|
|
/* problems I'd like to discourage this use unless absolutely */
|
|
/* necessary. */
|
|
#define DEFAULT_HEAP_SIZE -1
|
|
#define ACTUAL_DEFAULT_HEAP_SIZE 210000
|
|
|
|
struct obj
|
|
{union {struct {struct obj * car;
|
|
struct obj * cdr;} cons;
|
|
struct {double data;} flonum;
|
|
struct {const char *pname;
|
|
struct obj * vcell;} symbol;
|
|
struct {const char *name;
|
|
struct obj * (*f)(void);} subr0;
|
|
struct {const char *name;
|
|
struct obj * (*f)(struct obj *);} subr1;
|
|
struct {const char *name;
|
|
struct obj * (*f)(struct obj *, struct obj *);} subr2;
|
|
struct {const char *name;
|
|
struct obj * (*f)(struct obj *, struct obj *, struct obj *);
|
|
} subr3;
|
|
struct {const char *name;
|
|
struct obj * (*f)(struct obj *, struct obj *,
|
|
struct obj *, struct obj *);
|
|
} subr4;
|
|
struct {const char *name;
|
|
struct obj * (*f)(struct obj **, struct obj **);} subrm;
|
|
struct {const char *name;
|
|
struct obj * (*f)(void *,...);} subr;
|
|
struct {struct obj *env;
|
|
struct obj *code;} closure;
|
|
struct {long dim;
|
|
long *data;} long_array;
|
|
struct {long dim;
|
|
double *data;} double_array;
|
|
struct {long dim;
|
|
char *data;} string;
|
|
struct {long dim;
|
|
struct obj **data;} lisp_array;
|
|
struct {FILE *f;
|
|
char *name;} c_file;
|
|
struct {EST_Val *v;} val;
|
|
struct {void *p;} user;
|
|
}
|
|
storage_as;
|
|
char *pname; // This is currently only used by FLONM
|
|
short gc_mark;
|
|
short type;
|
|
};
|
|
|
|
#define CAR(x) ((*x).storage_as.cons.car)
|
|
#define CDR(x) ((*x).storage_as.cons.cdr)
|
|
#define PNAME(x) ((*x).storage_as.symbol.pname)
|
|
#define VCELL(x) ((*x).storage_as.symbol.vcell)
|
|
#define SUBR0(x) (*((*x).storage_as.subr0.f))
|
|
#define SUBR1(x) (*((*x).storage_as.subr1.f))
|
|
#define SUBR2(x) (*((*x).storage_as.subr2.f))
|
|
#define SUBR3(x) (*((*x).storage_as.subr3.f))
|
|
#define SUBR4(x) (*((*x).storage_as.subr4.f))
|
|
#define SUBRM(x) (*((*x).storage_as.subrm.f))
|
|
#define SUBRF(x) (*((*x).storage_as.subr.f))
|
|
#define FLONM(x) ((*x).storage_as.flonum.data)
|
|
#define FLONMPNAME(x) ((*x).pname)
|
|
#define USERVAL(x) ((*x).storage_as.user.p)
|
|
#define UNTYPEDVAL(x) ((*x).storage_as.user.p)
|
|
|
|
#define NIL ((struct obj *) 0)
|
|
#define EQ(x,y) ((x) == (y))
|
|
#define NEQ(x,y) ((x) != (y))
|
|
#define NULLP(x) EQ(x,NIL)
|
|
#define NNULLP(x) NEQ(x,NIL)
|
|
|
|
#define TYPE(x) (((x) == NIL) ? 0 : ((*(x)).type))
|
|
|
|
#define TYPEP(x,y) (TYPE(x) == (y))
|
|
#define NTYPEP(x,y) (TYPE(x) != (y))
|
|
|
|
#define tc_nil 0
|
|
#define tc_cons 1
|
|
#define tc_flonum 2
|
|
#define tc_symbol 3
|
|
#define tc_subr_0 4
|
|
#define tc_subr_1 5
|
|
#define tc_subr_2 6
|
|
#define tc_subr_3 7
|
|
#define tc_lsubr 8
|
|
#define tc_fsubr 9
|
|
#define tc_msubr 10
|
|
#define tc_closure 11
|
|
#define tc_free_cell 12
|
|
#define tc_string 13
|
|
#define tc_double_array 14
|
|
#define tc_long_array 15
|
|
#define tc_lisp_array 16
|
|
#define tc_c_file 17
|
|
#define tc_untyped 18
|
|
#define tc_subr_4 19
|
|
|
|
#define tc_sys_1 31
|
|
#define tc_sys_2 32
|
|
#define tc_sys_3 33
|
|
#define tc_sys_4 34
|
|
#define tc_sys_5 35
|
|
|
|
// older method for adding application specific types
|
|
#define tc_application_1 41
|
|
#define tc_application_2 42
|
|
#define tc_application_3 43
|
|
#define tc_application_4 44
|
|
#define tc_application_5 45
|
|
#define tc_application_6 46
|
|
#define tc_application_7 47
|
|
|
|
// Application specific types may be added using siod_register_user_type()
|
|
// Will increment from tc_first_user_type to tc_table_dim
|
|
#define tc_first_user_type 50
|
|
|
|
#define tc_table_dim 100
|
|
|
|
#define FO_fetch 127
|
|
#define FO_store 126
|
|
#define FO_list 125
|
|
#define FO_listd 124
|
|
|
|
typedef struct obj* LISP;
|
|
typedef LISP (*SUBR_FUNC)(void);
|
|
|
|
#define CONSP(x) TYPEP(x,tc_cons)
|
|
#define FLONUMP(x) TYPEP(x,tc_flonum)
|
|
#define SYMBOLP(x) TYPEP(x,tc_symbol)
|
|
#define STRINGP(x) TYPEP(x,tc_string)
|
|
|
|
#define NCONSP(x) NTYPEP(x,tc_cons)
|
|
#define NFLONUMP(x) NTYPEP(x,tc_flonum)
|
|
#define NSYMBOLP(x) NTYPEP(x,tc_symbol)
|
|
|
|
// Not for the purists, but I find these more readable than the equivalent
|
|
// code inline.
|
|
|
|
#define CAR1(x) CAR(x)
|
|
#define CDR1(x) CDR(x)
|
|
#define CAR2(x) CAR(CDR1(x))
|
|
#define CDR2(x) CDR(CDR1(x))
|
|
#define CAR3(x) CAR(CDR2(x))
|
|
#define CDR3(x) CDR(CDR2(x))
|
|
#define CAR4(x) CAR(CDR3(x))
|
|
#define CDR4(x) CDR(CDR3(x))
|
|
#define CAR5(x) CAR(CDR4(x))
|
|
#define CDR5(x) CDR(CDR4(x))
|
|
|
|
#define LISTP(x) (NULLP(x) || CONSP(x))
|
|
#define LIST1P(x) (CONSP(x) && NULLP(CDR(x)))
|
|
#define LIST2P(x) (CONSP(x) && CONSP(CDR1(x)) && NULLP(CDR2(x)))
|
|
#define LIST3P(x) (CONSP(x) && CONSP(CDR1(x)) && CONSP(CDR2(x)) && NULLP(CDR3(x)))
|
|
#define LIST4P(x) (CONSP(x) && CONSP(CDR1(x)) && CONSP(CDR2(x)) && CONSP(CDR3(x)) && NULLP(CDR4(x)))
|
|
#define LIST5P(x) (CONSP(x) && CONSP(CDR1(x)) && CONSP(CDR2(x)) && CONSP(CDR3(x)) && CONSP(CDR4(x)) && NULLP(CDR5(x)))
|
|
|
|
#define MKPTR(x) (siod_make_ptr((void *)x))
|
|
|
|
struct gen_readio
|
|
{int (*getc_fcn)(char *);
|
|
void (*ungetc_fcn)(int, char *);
|
|
char *cb_argument;};
|
|
|
|
#define GETC_FCN(x) (*((*x).getc_fcn))((*x).cb_argument)
|
|
#define UNGETC_FCN(c,x) (*((*x).ungetc_fcn))(c,(*x).cb_argument)
|
|
|
|
struct repl_hooks
|
|
{void (*repl_puts)(char *);
|
|
LISP (*repl_read)(void);
|
|
LISP (*repl_eval)(LISP);
|
|
void (*repl_print)(LISP);};
|
|
|
|
/* Macro for defining new class as values public functions */
|
|
#define SIOD_REGISTER_CLASS_DCLS(NAME,CLASS) \
|
|
class CLASS *NAME(LISP x); \
|
|
int NAME##_p(LISP x); \
|
|
EST_Val est_val(const class CLASS *v); \
|
|
LISP siod(const class CLASS *v);
|
|
|
|
/* Macro for defining new class as siod */
|
|
#define SIOD_REGISTER_CLASS(NAME,CLASS) \
|
|
class CLASS *NAME(LISP x) \
|
|
{ \
|
|
return NAME(val(x)); \
|
|
} \
|
|
\
|
|
int NAME##_p(LISP x) \
|
|
{ \
|
|
if (val_p(x) && \
|
|
(val_type_##NAME == val(x).type())) \
|
|
return TRUE; \
|
|
else \
|
|
return FALSE; \
|
|
} \
|
|
\
|
|
LISP siod(const class CLASS *v) \
|
|
{ \
|
|
if (v == 0) \
|
|
return NIL; \
|
|
else \
|
|
return siod(est_val(v)); \
|
|
} \
|
|
|
|
|
|
/* Macro for defining typedefed something as values public functions */
|
|
#define SIOD_REGISTER_TYPE_DCLS(NAME,CLASS) \
|
|
CLASS *NAME(LISP x); \
|
|
int NAME##_p(LISP x); \
|
|
EST_Val est_val(const CLASS *v); \
|
|
LISP siod(const CLASS *v);
|
|
|
|
/* Macro for defining new class as siod */
|
|
#define SIOD_REGISTER_TYPE(NAME,CLASS) \
|
|
CLASS *NAME(LISP x) \
|
|
{ \
|
|
return NAME(val(x)); \
|
|
} \
|
|
\
|
|
int NAME##_p(LISP x) \
|
|
{ \
|
|
if (val_p(x) && \
|
|
(val_type_##NAME == val(x).type())) \
|
|
return TRUE; \
|
|
else \
|
|
return FALSE; \
|
|
} \
|
|
\
|
|
LISP siod(const CLASS *v) \
|
|
{ \
|
|
if (v == 0) \
|
|
return NIL; \
|
|
else \
|
|
return siod(est_val(v)); \
|
|
} \
|
|
|
|
|
|
/* Macro for defining function ptr as siod */
|
|
#define SIOD_REGISTER_FUNCPTR(NAME,CLASS) \
|
|
CLASS NAME(LISP x) \
|
|
{ \
|
|
return NAME(val(x)); \
|
|
} \
|
|
\
|
|
int NAME##_p(LISP x) \
|
|
{ \
|
|
if (val_p(x) && \
|
|
(val_type_##NAME == val(x).type())) \
|
|
return TRUE; \
|
|
else \
|
|
return FALSE; \
|
|
} \
|
|
\
|
|
LISP siod(const CLASS v) \
|
|
{ \
|
|
if (v == 0) \
|
|
return NIL; \
|
|
else \
|
|
return siod(est_val(v)); \
|
|
} \
|
|
|
|
#endif
|