1 /* Scheme In One Defun, but in C this time. 2 3 * COPYRIGHT (c) 1988-1994 BY * 4 * PARADIGM ASSOCIATES INCORPORATED, CAMBRIDGE, MASSACHUSETTS. * 5 * See the source file SLIB.C for more information. * 6 7 */ 8 9 /*************************************************************************/ 10 /* Author : Alan W Black */ 11 /* Date : March 1999 */ 12 /*-----------------------------------------------------------------------*/ 13 /* */ 14 /* Struct and macro definitions for SIOD */ 15 /* */ 16 /*=======================================================================*/ 17 #ifndef __EST_SIOD_DEFS_H__ 18 #define __EST_SIOD_DEFS_H__ 19 20 /* This states the default heap size is effective unset */ 21 /* The size if no heap is specified by a command argument, the */ 22 /* value of the environment variable SIODHEAPSIZE will be used */ 23 /* otherwise ACTUAL_DEFAULT_HEAP_SIZE is used. This is *not* */ 24 /* documented because environment variables can cause so many */ 25 /* problems I'd like to discourage this use unless absolutely */ 26 /* necessary. */ 27 #define DEFAULT_HEAP_SIZE -1 28 #define ACTUAL_DEFAULT_HEAP_SIZE 210000 29 30 struct obj 31 {union {struct {struct obj * car; 32 struct obj * cdr;} cons; 33 struct {double data;} flonum; 34 struct {const char *pname; 35 struct obj * vcell;} symbol; 36 struct {const char *name; 37 struct obj * (*f)(void);} subr0; 38 struct {const char *name; 39 struct obj * (*f)(struct obj *);} subr1; 40 struct {const char *name; 41 struct obj * (*f)(struct obj *, struct obj *);} subr2; 42 struct {const char *name; 43 struct obj * (*f)(struct obj *, struct obj *, struct obj *); 44 } subr3; 45 struct {const char *name; 46 struct obj * (*f)(struct obj *, struct obj *, 47 struct obj *, struct obj *); 48 } subr4; 49 struct {const char *name; 50 struct obj * (*f)(struct obj **, struct obj **);} subrm; 51 struct {const char *name; 52 struct obj * (*f)(void *,...);} subr; 53 struct {struct obj *env; 54 struct obj *code;} closure; 55 struct {long dim; 56 long *data;} long_array; 57 struct {long dim; 58 double *data;} double_array; 59 struct {long dim; 60 char *data;} string; 61 struct {long dim; 62 struct obj **data;} lisp_array; 63 struct {FILE *f; 64 char *name;} c_file; 65 struct {EST_Val *v;} val; 66 struct {void *p;} user; 67 } 68 storage_as; 69 char *pname; // This is currently only used by FLONM 70 short gc_mark; 71 short type; 72 }; 73 74 #define CAR(x) ((*x).storage_as.cons.car) 75 #define CDR(x) ((*x).storage_as.cons.cdr) 76 #define PNAME(x) ((*x).storage_as.symbol.pname) 77 #define VCELL(x) ((*x).storage_as.symbol.vcell) 78 #define SUBR0(x) (*((*x).storage_as.subr0.f)) 79 #define SUBR1(x) (*((*x).storage_as.subr1.f)) 80 #define SUBR2(x) (*((*x).storage_as.subr2.f)) 81 #define SUBR3(x) (*((*x).storage_as.subr3.f)) 82 #define SUBR4(x) (*((*x).storage_as.subr4.f)) 83 #define SUBRM(x) (*((*x).storage_as.subrm.f)) 84 #define SUBRF(x) (*((*x).storage_as.subr.f)) 85 #define FLONM(x) ((*x).storage_as.flonum.data) 86 #define FLONMPNAME(x) ((*x).pname) 87 #define USERVAL(x) ((*x).storage_as.user.p) 88 #define UNTYPEDVAL(x) ((*x).storage_as.user.p) 89 90 #define NIL ((struct obj *) 0) 91 #define EQ(x,y) ((x) == (y)) 92 #define NEQ(x,y) ((x) != (y)) 93 #define NULLP(x) EQ(x,NIL) 94 #define NNULLP(x) NEQ(x,NIL) 95 96 #define TYPE(x) (((x) == NIL) ? 0 : ((*(x)).type)) 97 98 #define TYPEP(x,y) (TYPE(x) == (y)) 99 #define NTYPEP(x,y) (TYPE(x) != (y)) 100 101 #define tc_nil 0 102 #define tc_cons 1 103 #define tc_flonum 2 104 #define tc_symbol 3 105 #define tc_subr_0 4 106 #define tc_subr_1 5 107 #define tc_subr_2 6 108 #define tc_subr_3 7 109 #define tc_lsubr 8 110 #define tc_fsubr 9 111 #define tc_msubr 10 112 #define tc_closure 11 113 #define tc_free_cell 12 114 #define tc_string 13 115 #define tc_double_array 14 116 #define tc_long_array 15 117 #define tc_lisp_array 16 118 #define tc_c_file 17 119 #define tc_untyped 18 120 #define tc_subr_4 19 121 122 #define tc_sys_1 31 123 #define tc_sys_2 32 124 #define tc_sys_3 33 125 #define tc_sys_4 34 126 #define tc_sys_5 35 127 128 // older method for adding application specific types 129 #define tc_application_1 41 130 #define tc_application_2 42 131 #define tc_application_3 43 132 #define tc_application_4 44 133 #define tc_application_5 45 134 #define tc_application_6 46 135 #define tc_application_7 47 136 137 // Application specific types may be added using siod_register_user_type() 138 // Will increment from tc_first_user_type to tc_table_dim 139 #define tc_first_user_type 50 140 141 #define tc_table_dim 100 142 143 #define FO_fetch 127 144 #define FO_store 126 145 #define FO_list 125 146 #define FO_listd 124 147 148 typedef struct obj* LISP; 149 typedef LISP (*SUBR_FUNC)(void); 150 151 #define CONSP(x) TYPEP(x,tc_cons) 152 #define FLONUMP(x) TYPEP(x,tc_flonum) 153 #define SYMBOLP(x) TYPEP(x,tc_symbol) 154 #define STRINGP(x) TYPEP(x,tc_string) 155 156 #define NCONSP(x) NTYPEP(x,tc_cons) 157 #define NFLONUMP(x) NTYPEP(x,tc_flonum) 158 #define NSYMBOLP(x) NTYPEP(x,tc_symbol) 159 160 // Not for the purists, but I find these more readable than the equivalent 161 // code inline. 162 163 #define CAR1(x) CAR(x) 164 #define CDR1(x) CDR(x) 165 #define CAR2(x) CAR(CDR1(x)) 166 #define CDR2(x) CDR(CDR1(x)) 167 #define CAR3(x) CAR(CDR2(x)) 168 #define CDR3(x) CDR(CDR2(x)) 169 #define CAR4(x) CAR(CDR3(x)) 170 #define CDR4(x) CDR(CDR3(x)) 171 #define CAR5(x) CAR(CDR4(x)) 172 #define CDR5(x) CDR(CDR4(x)) 173 174 #define LISTP(x) (NULLP(x) || CONSP(x)) 175 #define LIST1P(x) (CONSP(x) && NULLP(CDR(x))) 176 #define LIST2P(x) (CONSP(x) && CONSP(CDR1(x)) && NULLP(CDR2(x))) 177 #define LIST3P(x) (CONSP(x) && CONSP(CDR1(x)) && CONSP(CDR2(x)) && NULLP(CDR3(x))) 178 #define LIST4P(x) (CONSP(x) && CONSP(CDR1(x)) && CONSP(CDR2(x)) && CONSP(CDR3(x)) && NULLP(CDR4(x))) 179 #define LIST5P(x) (CONSP(x) && CONSP(CDR1(x)) && CONSP(CDR2(x)) && CONSP(CDR3(x)) && CONSP(CDR4(x)) && NULLP(CDR5(x))) 180 181 #define MKPTR(x) (siod_make_ptr((void *)x)) 182 183 struct gen_readio 184 {int (*getc_fcn)(char *); 185 void (*ungetc_fcn)(int, char *); 186 char *cb_argument;}; 187 188 #define GETC_FCN(x) (*((*x).getc_fcn))((*x).cb_argument) 189 #define UNGETC_FCN(c,x) (*((*x).ungetc_fcn))(c,(*x).cb_argument) 190 191 struct repl_hooks 192 {void (*repl_puts)(char *); 193 LISP (*repl_read)(void); 194 LISP (*repl_eval)(LISP); 195 void (*repl_print)(LISP);}; 196 197 /* Macro for defining new class as values public functions */ 198 #define SIOD_REGISTER_CLASS_DCLS(NAME,CLASS) \ 199 class CLASS *NAME(LISP x); \ 200 int NAME##_p(LISP x); \ 201 EST_Val est_val(const class CLASS *v); \ 202 LISP siod(const class CLASS *v); 203 204 /* Macro for defining new class as siod */ 205 #define SIOD_REGISTER_CLASS(NAME,CLASS) \ 206 class CLASS *NAME(LISP x) \ 207 { \ 208 return NAME(val(x)); \ 209 } \ 210 \ 211 int NAME##_p(LISP x) \ 212 { \ 213 if (val_p(x) && \ 214 (val_type_##NAME == val(x).type())) \ 215 return TRUE; \ 216 else \ 217 return FALSE; \ 218 } \ 219 \ 220 LISP siod(const class CLASS *v) \ 221 { \ 222 if (v == 0) \ 223 return NIL; \ 224 else \ 225 return siod(est_val(v)); \ 226 } \ 227 228 229 /* Macro for defining typedefed something as values public functions */ 230 #define SIOD_REGISTER_TYPE_DCLS(NAME,CLASS) \ 231 CLASS *NAME(LISP x); \ 232 int NAME##_p(LISP x); \ 233 EST_Val est_val(const CLASS *v); \ 234 LISP siod(const CLASS *v); 235 236 /* Macro for defining new class as siod */ 237 #define SIOD_REGISTER_TYPE(NAME,CLASS) \ 238 CLASS *NAME(LISP x) \ 239 { \ 240 return NAME(val(x)); \ 241 } \ 242 \ 243 int NAME##_p(LISP x) \ 244 { \ 245 if (val_p(x) && \ 246 (val_type_##NAME == val(x).type())) \ 247 return TRUE; \ 248 else \ 249 return FALSE; \ 250 } \ 251 \ 252 LISP siod(const CLASS *v) \ 253 { \ 254 if (v == 0) \ 255 return NIL; \ 256 else \ 257 return siod(est_val(v)); \ 258 } \ 259 260 261 /* Macro for defining function ptr as siod */ 262 #define SIOD_REGISTER_FUNCPTR(NAME,CLASS) \ 263 CLASS NAME(LISP x) \ 264 { \ 265 return NAME(val(x)); \ 266 } \ 267 \ 268 int NAME##_p(LISP x) \ 269 { \ 270 if (val_p(x) && \ 271 (val_type_##NAME == val(x).type())) \ 272 return TRUE; \ 273 else \ 274 return FALSE; \ 275 } \ 276 \ 277 LISP siod(const CLASS v) \ 278 { \ 279 if (v == 0) \ 280 return NIL; \ 281 else \ 282 return siod(est_val(v)); \ 283 } \ 284 285 #endif 286