1 /* scheme-private.h */ 2 3 #ifndef _SCHEME_PRIVATE_H 4 #define _SCHEME_PRIVATE_H 5 6 #include "scheme.h" 7 /*------------------ Ugly internals -----------------------------------*/ 8 /*------------------ Of interest only to FFI users --------------------*/ 9 10 enum scheme_port_kind { 11 port_free=0, 12 port_file=1, 13 port_string=2, 14 port_input=16, 15 port_output=32 16 }; 17 18 typedef struct port { 19 unsigned char kind; 20 union { 21 struct { 22 FILE *file; 23 int closeit; 24 #if USE_FILE_AND_LINE 25 char *name; 26 int line; 27 #endif 28 } stdio; 29 struct { 30 char *start; 31 char *past_the_end; 32 char *curr; 33 } string; 34 } rep; 35 } port; 36 37 /* cell structure */ 38 struct cell { 39 #if USE_PROTECT 40 struct list plist; 41 int pref; 42 #endif 43 unsigned int _flag; 44 union { 45 struct { 46 char *_svalue; 47 int _length; 48 } _string; 49 num _number; 50 port *_port; 51 foreign_func _ff; 52 struct { 53 struct cell *_car; 54 struct cell *_cdr; 55 } _cons; 56 } _object; 57 }; 58 59 struct scheme { 60 /* arrays for segments */ 61 func_alloc malloc; 62 func_dealloc free; 63 64 /* return code */ 65 int retcode; 66 int tracing; 67 68 #define CELL_SEGSIZE 16*5000 /* # of cells in one segment */ 69 #define CELL_NSEGMENT 10 /* # of segments for cells */ 70 char *alloc_seg[CELL_NSEGMENT]; 71 pointer cell_seg[CELL_NSEGMENT]; 72 int last_cell_seg; 73 74 /* We use 4 registers. */ 75 pointer args; /* register for arguments of function */ 76 pointer envir; /* stack register for current environment */ 77 pointer code; /* register for current code */ 78 pointer dump; /* stack register for next evaluation */ 79 80 int interactive_repl; /* are we in an interactive REPL? */ 81 82 struct cell _sink; 83 pointer sink; /* when mem. alloc. fails */ 84 struct cell _NIL; 85 pointer NIL; /* special cell representing empty cell */ 86 struct cell _HASHT; 87 pointer T; /* special cell representing #t */ 88 struct cell _HASHF; 89 pointer F; /* special cell representing #f */ 90 struct cell _EOF_OBJ; 91 pointer EOF_OBJ; /* special cell representing end-of-file object */ 92 pointer oblist; /* pointer to symbol table */ 93 pointer global_env; /* pointer to global environment */ 94 95 /* global pointers to special symbols */ 96 pointer LAMBDA; /* pointer to syntax lambda */ 97 pointer QUOTE; /* pointer to syntax quote */ 98 99 pointer QQUOTE; /* pointer to symbol quasiquote */ 100 pointer UNQUOTE; /* pointer to symbol unquote */ 101 pointer UNQUOTESP; /* pointer to symbol unquote-splicing */ 102 pointer FEED_TO; /* => */ 103 pointer COLON_HOOK; /* *colon-hook* */ 104 pointer ERROR_HOOK; /* *error-hook* */ 105 pointer SHARP_HOOK; /* *sharp-hook* */ 106 107 pointer free_cell; /* pointer to top of free cells */ 108 long fcells; /* # of free cells */ 109 110 pointer inport; 111 pointer outport; 112 pointer save_inport; 113 pointer loadport; 114 115 #define MAXFIL 64 116 port load_stack[MAXFIL]; /* Stack of open files for port -1 (LOADing) */ 117 int nesting_stack[MAXFIL]; 118 int file_i; 119 int nesting; 120 121 char gc_verbose; /* if gc_verbose is not zero, print gc status */ 122 char no_memory; /* Whether mem. alloc. has failed */ 123 124 #define LINESIZE 1024 125 char linebuff[LINESIZE]; 126 char strbuff[256]; 127 128 FILE *tmpfp; 129 int tok; 130 int print_flag; 131 pointer value; 132 int op; 133 134 void *ext_data; /* For the benefit of foreign functions */ 135 long gensym_cnt; 136 137 struct scheme_interface *vptr; 138 void *dump_base; /* pointer to base of allocated dump stack */ 139 int dump_size; /* number of frames allocated for dump stack */ 140 141 #if USE_PROTECT 142 struct list protect; 143 int ignore_protect; 144 #endif 145 char inside; /* gmcnutt: flag to check recursive entry from C */ 146 147 #if USE_CUSTOM_FINALIZE 148 void (*custom_finalize)(scheme *sc, pointer pp); 149 #endif 150 }; 151 152 #define cons(sc,a,b) _cons(sc,a,b,0) 153 #define immutable_cons(sc,a,b) _cons(sc,a,b,1) 154 155 int is_string(pointer p); 156 char *string_value(pointer p); 157 int is_number(pointer p); 158 num nvalue(pointer p); 159 long ivalue(pointer p); 160 double rvalue(pointer p); 161 int is_integer(pointer p); 162 int is_real(pointer p); 163 int is_character(pointer p); 164 long charvalue(pointer p); 165 int is_vector(pointer p); 166 167 int is_port(pointer p); 168 169 int is_pair(pointer p); 170 pointer pair_car(pointer p); 171 pointer pair_cdr(pointer p); 172 pointer set_car(pointer p, pointer q); 173 pointer set_cdr(pointer p, pointer q); 174 175 int is_symbol(pointer p); 176 char *symname(pointer p); 177 int hasprop(pointer p); 178 179 int is_syntax(pointer p); 180 int is_proc(pointer p); 181 int is_foreign(pointer p); 182 char *syntaxname(pointer p); 183 int is_closure(pointer p); 184 #ifdef USE_MACRO 185 int is_macro(pointer p); 186 #endif 187 pointer closure_code(pointer p); 188 pointer closure_env(pointer p); 189 190 int is_continuation(pointer p); 191 int is_promise(pointer p); 192 int is_environment(pointer p); 193 int is_immutable(pointer p); 194 void setimmutable(pointer p); 195 int scm_len(scheme *sc, pointer list); 196 197 /* convenience macros for extrenal code that uses scheme internals */ 198 #define scm_protect(sc, cell) \ 199 (sc)->vptr->protect((sc), (cell)) 200 201 #define scm_unprotect(sc, cell) \ 202 (sc)->vptr->unprotect((sc), (cell)) 203 204 #define scm_mk_ptr(sc, val) \ 205 (sc)->vptr->mk_foreign_func((sc), (foreign_func)(val)) 206 207 #define scm_mk_integer(sc, val) \ 208 (sc)->vptr->mk_integer((sc), (val)) 209 210 #define scm_mk_symbol(sc, val) \ 211 (sc)->vptr->mk_symbol((sc), (val)) 212 213 #define scm_mk_string(sc, val) \ 214 (sc)->vptr->mk_string((sc), (val)) 215 216 #define scm_define(sc, sym, val) \ 217 (sc)->vptr->scheme_define((sc), \ 218 (sc)->global_env, \ 219 (sc)->vptr->mk_symbol(sc, (sym)), \ 220 (val)) 221 222 223 #define scm_define_int(sc, sym, val) \ 224 scm_define(sc, sym, (sc)->vptr->mk_integer((sc), (val))) 225 226 #define scm_define_bool(sc, sym, val) \ 227 scm_define(sc, sym, (val) ? (sc)->T : (sc)->F) 228 229 #define scm_define_ptr(sc, sym, val) \ 230 scm_define(sc, sym, scm_mk_ptr(sc, val)) 231 232 #define scm_is_pair(sc,arg) ((sc)->vptr->is_pair(arg)) 233 #define scm_is_num(sc, arg) ((sc)->vptr->is_number(arg)) 234 #define scm_is_int(sc, arg) ((sc)->vptr->is_integer(arg)) 235 #define scm_is_real(sc, arg) ((sc)->vptr->is_real(arg)) 236 #define scm_is_str(sc, arg) ((sc)->vptr->is_string(arg)) 237 #define scm_is_sym(sc, arg) ((sc)->vptr->is_symbol(arg)) 238 #define scm_is_ptr(sc, arg) ((sc)->vptr->is_foreign(arg)) 239 #define scm_is_closure(sc, arg) ((sc)->vptr->is_closure(arg)) 240 241 #define scm_car(sc, arg) ((sc)->vptr->pair_car(arg)) 242 #define scm_cdr(sc, arg) ((sc)->vptr->pair_cdr(arg)) 243 244 #define scm_str_val(sc, arg) ((sc)->vptr->string_value(arg)) 245 #define scm_ptr_val(sc, arg) ((void*)(arg)->_object._ff) 246 #define scm_int_val(sc, arg) ((sc)->vptr->ivalue(arg)) 247 #define scm_real_val(sc, arg) ((sc)->vptr->rvalue(arg)) 248 #define scm_sym_val(sc, arg) ((sc)->vptr->symname(arg)) 249 #define scm_closure_code(sc, arg) ((sc)->vptr->closure_code(arg)) 250 #define scm_closure_env(sc, arg) ((sc)->vptr->closure_env(arg)) 251 252 #define scm_set_cust_fin(sc, arg) ((sc)->vptr->setcustfin(arg)) 253 254 255 #endif 256