tinyscheme_genesi... 1
tinyscheme_genesi... 2 How to hack TinyScheme
tinyscheme_genesi... 3 ----------------------
tinyscheme_genesi... 4
tinyscheme_genesi... 5 TinyScheme is easy to learn and modify. It is structured like a
tinyscheme_genesi... 6 meta-interpreter, only it is written in C. All data are Scheme
tinyscheme_genesi... 7 objects, which facilitates both understanding/modifying the
tinyscheme_genesi... 8 code and reifying the interpreter workings.
tinyscheme_genesi... 9
tinyscheme_genesi... 10 In place of a dry description, we will pace through the addition
tinyscheme_genesi... 11 of a useful new datatype: garbage-collected memory blocks.
tinyscheme_genesi... 12 The interface will be:
tinyscheme_genesi... 13
tinyscheme_genesi... 14 (make-block <n> [<fill>]) makes a new block of the specified size
tinyscheme_genesi... 15 optionally filling it with a specified byte
tinyscheme_genesi... 16 (block? <obj>)
tinyscheme_genesi... 17 (block-length <block>)
tinyscheme_genesi... 18 (block-ref <block> <index>) retrieves byte at location
tinyscheme_genesi... 19 (block-set! <block> <index> <byte>) modifies byte at location
tinyscheme_genesi... 20
tinyscheme_genesi... 21 In the sequel, lines that begin with '>' denote lines to add to the
tinyscheme_genesi... 22 code. Lines that begin with '|' are just citations of existing code.
tinyscheme_genesi... 23 Lines that begin with X denote lines to be removed from the code.
tinyscheme_genesi... 24
tinyscheme_genesi... 25 First of all, we need to assign a typeid to our new type. Typeids
tinyscheme_genesi... 26 in TinyScheme are small integers declared in the scheme_types enum
tinyscheme_genesi... 27 located near the top of the scheme.c file; it begins with T_STRING.
tinyscheme_genesi... 28 Add a new entry at the end, say T_MEMBLOCK. Remember to adjust the
tinyscheme_genesi... 29 value of T_LAST_SYTEM_TYPE when adding new entries. There can be at
tinyscheme_genesi... 30 most 31 types, but you don't have to worry about that limit yet.
tinyscheme_genesi... 31
tinyscheme_genesi... 32 | T_ENVIRONMENT=14,
tinyscheme_genesi... 33 X T_LAST_SYSTEM_TYPE=14
tinyscheme_genesi... 34 > T_MEMBLOCK=15,
tinyscheme_genesi... 35 > T_LAST_SYSTEM_TYPE=15
tinyscheme_genesi... 36 | };
tinyscheme_genesi... 37
tinyscheme_genesi... 38
tinyscheme_genesi... 39 Then, some helper macros would be useful. Go to where is_string()
tinyscheme_genesi... 40 and the rest are defined and add:
tinyscheme_genesi... 41
tinyscheme_genesi... 42 > INTERFACE INLINE int is_memblock(pointer p) { return (type(p)==T_MEMBLOCK); }
tinyscheme_genesi... 43
tinyscheme_genesi... 44 This actually is a function, because it is meant to be exported by
tinyscheme_genesi... 45 scheme.h. If no foreign function will ever manipulate a memory block,
tinyscheme_genesi... 46 you can instead define it as a macro:
tinyscheme_genesi... 47
tinyscheme_genesi... 48 > #define is_memblock(p) (type(p)==T_MEMBLOCK)
tinyscheme_genesi... 49
tinyscheme_genesi... 50 Then we make space for the new type in the main data structure:
tinyscheme_genesi... 51 struct cell. As it happens, the _string part of the union _object
tinyscheme_genesi... 52 (that is used to hold character strings) has two fields that suit us:
tinyscheme_genesi... 53
tinyscheme_genesi... 54 | struct {
tinyscheme_genesi... 55 | char *_svalue;
tinyscheme_genesi... 56 | int _keynum;
tinyscheme_genesi... 57 | } _string;
tinyscheme_genesi... 58
tinyscheme_genesi... 59 We can use _svalue to hold the actual pointer and _keynum to hold its
tinyscheme_genesi... 60 length. If we couln't reuse existing fields, we could always add other
tinyscheme_genesi... 61 alternatives in union _object.
tinyscheme_genesi... 62
tinyscheme_genesi... 63 We then proceed to write the function that actually makes a new block.
tinyscheme_genesi... 64 For conformance reasons, we name it mk_memblock
tinyscheme_genesi... 65
tinyscheme_genesi... 66 > static pointer mk_memblock(scheme *sc, int len, char fill) {
tinyscheme_genesi... 67 > pointer x;
tinyscheme_genesi... 68 > char *p=(char*)sc->malloc(len);
tinyscheme_genesi... 69 >
tinyscheme_genesi... 70 > if(p==0) {
tinyscheme_genesi... 71 > return sc->NIL;
tinyscheme_genesi... 72 > }
tinyscheme_genesi... 73 > x = get_cell(sc, sc->NIL, sc->NIL);
tinyscheme_genesi... 74 >
tinyscheme_genesi... 75 > typeflag(x) = T_MEMBLOCK|T_ATOM;
tinyscheme_genesi... 76 > strvalue(x)=p;
tinyscheme_genesi... 77 > keynum(x)=len;
tinyscheme_genesi... 78 > memset(p,fill,len);
tinyscheme_genesi... 79 > return (x);
tinyscheme_genesi... 80 > }
tinyscheme_genesi... 81
tinyscheme_genesi... 82 The memory used by the MEMBLOCK will have to be freed when the cell
tinyscheme_genesi... 83 is reclaimed during garbage collection. There is a placeholder for
tinyscheme_genesi... 84 that staff, function finalize_cell(), currently handling strings only.
tinyscheme_genesi... 85
tinyscheme_genesi... 86 | static void finalize_cell(scheme *sc, pointer a) {
tinyscheme_genesi... 87 | if(is_string(a)) {
tinyscheme_genesi... 88 | sc->free(strvalue(a));
tinyscheme_genesi... 89 > } else if(is_memblock(a)) {
tinyscheme_genesi... 90 > sc->free(strvalue(a));
tinyscheme_genesi... 91 | } else if(is_port(a)) {
tinyscheme_genesi... 92
tinyscheme_genesi... 93 There are no MEMBLOCK literals, so we don't concern ourselves with
tinyscheme_genesi... 94 the READER part (yet!). We must cater to the PRINTER, though. We
tinyscheme_genesi... 95 add one case more in atom2str().
tinyscheme_genesi... 96
tinyscheme_genesi... 97 | } else if (iscontinuation(l)) {
tinyscheme_genesi... 98 | p = "#<CONTINUATION>";
tinyscheme_genesi... 99 > } else if (is_memblock(l)) {
tinyscheme_genesi... 100 > p = "#<MEMORY BLOCK>";
tinyscheme_genesi... 101 | } else {
tinyscheme_genesi... 102
tinyscheme_genesi... 103 Whenever a MEMBLOCK is displayed, it will look like that.
tinyscheme_genesi... 104 Now, we must add the interface functions: constructor, predicate,
tinyscheme_genesi... 105 accessor, modifier. We must in fact create new op-codes for the virtual
tinyscheme_genesi... 106 machine underlying TinyScheme. Since version 1.30, TinyScheme uses
tinyscheme_genesi... 107 macros and a single source text to keep the enums and the dispatch table
tinyscheme_genesi... 108 in sync. The op-codes are defined in the opdefines.h file with one line
tinyscheme_genesi... 109 for each op-code. The lines in the file have six columns between the
tinyscheme_genesi... 110 starting _OPDEF( and ending ): A, B, C, D, E, and OP.
tinyscheme_genesi... 111 Note that this file uses unusually long lines to accomodate all the
tinyscheme_genesi... 112 information; adjust your editor to handle this.
tinyscheme_genesi... 113
tinyscheme_genesi... 114 The purpose of the columns is:
tinyscheme_genesi... 115 - Column A is the name of the subroutine that handles the op-code.
tinyscheme_genesi... 116 - Column B is the name of the op-code function.
tinyscheme_genesi... 117 - Columns C and D are the minimum and maximum number of arguments
tinyscheme_genesi... 118 that are accepted by the op-code.
tinyscheme_genesi... 119 - Column E is a set of flags that tells the interpreter the type of
tinyscheme_genesi... 120 each of the arguments expected by the op-code.
tinyscheme_genesi... 121 - Column OP is used in the scheme_opcodes enum located in the
tinyscheme_genesi... 122 scheme-private.h file.
tinyscheme_genesi... 123
tinyscheme_genesi... 124 Op-codes are really just tags for a huge C switch, only this switch
tinyscheme_genesi... 125 is broken up in to a number of different opexe_X functions. The
tinyscheme_genesi... 126 correspondence is made in table "dispatch_table". There, we assign
tinyscheme_genesi... 127 the new op-codes to opexe_2, where the equivalent ones for vectors
tinyscheme_genesi... 128 are situated. We also assign a name for them, and specify the minimum
tinyscheme_genesi... 129 and maximum arity (number of expected arguments). INF_ARG as a maximum
tinyscheme_genesi... 130 arity means "unlimited".
tinyscheme_genesi... 131
tinyscheme_genesi... 132 For reasons of consistency, we add the new op-codes right after those
tinyscheme_genesi... 133 for vectors:
tinyscheme_genesi... 134
tinyscheme_genesi... 135 | _OP_DEF(opexe_2, "vector-set!", 3, 3, TST_VECTOR TST_NATURAL TST_ANY, OP_VECSET )
tinyscheme_genesi... 136 > _OP_DEF(opexe_2, "make-block", 1, 2, TST_NATURAL TST_CHAR, OP_MKBLOCK )
tinyscheme_genesi... 137 > _OP_DEF(opexe_2, "block-length", 1, 1, T_MEMBLOCK, OP_BLOCKLEN )
tinyscheme_genesi... 138 > _OP_DEF(opexe_2, "block-ref", 2, 2, T_MEMBLOCK TST_NATURAL, OP_BLOCKREF )
tinyscheme_genesi... 139 > _OP_DEF(opexe_2, "block-set!", 1, 1, T_MEMBLOCK TST_NATURAL TST_CHAR, OP_BLOCKSET )
tinyscheme_genesi... 140 | _OP_DEF(opexe_3, "not", 1, 1, TST_NONE, OP_NOT )
tinyscheme_genesi... 141
tinyscheme_genesi... 142 We add the predicate along with the other predicates in opexe_3:
tinyscheme_genesi... 143
tinyscheme_genesi... 144 | _OP_DEF(opexe_3, "vector?", 1, 1, TST_ANY, OP_VECTORP )
tinyscheme_genesi... 145 > _OP_DEF(opexe_3, "block?", 1, 1, TST_ANY, OP_BLOCKP )
tinyscheme_genesi... 146 | _OP_DEF(opexe_3, "eq?", 2, 2, TST_ANY, OP_EQ )
tinyscheme_genesi... 147
tinyscheme_genesi... 148 All that remains is to write the actual code to do the processing and
tinyscheme_genesi... 149 add it to the switch statement in opexe_2, after the OP_VECSET case.
tinyscheme_genesi... 150
tinyscheme_genesi... 151 > case OP_MKBLOCK: { /* make-block */
tinyscheme_genesi... 152 > int fill=0;
tinyscheme_genesi... 153 > int len;
tinyscheme_genesi... 154 >
tinyscheme_genesi... 155 > if(!isnumber(car(sc->args))) {
tinyscheme_genesi... 156 > Error_1(sc,"make-block: not a number:",car(sc->args));
tinyscheme_genesi... 157 > }
tinyscheme_genesi... 158 > len=ivalue(car(sc->args));
tinyscheme_genesi... 159 > if(len<=0) {
tinyscheme_genesi... 160 > Error_1(sc,"make-block: not positive:",car(sc->args));
tinyscheme_genesi... 161 > }
tinyscheme_genesi... 162 >
tinyscheme_genesi... 163 > if(cdr(sc->args)!=sc->NIL) {
tinyscheme_genesi... 164 > if(!isnumber(cadr(sc->args)) || ivalue(cadr(sc->args))<0) {
tinyscheme_genesi... 165 > Error_1(sc,"make-block: not a positive number:",cadr(sc->args));
tinyscheme_genesi... 166 > }
tinyscheme_genesi... 167 > fill=charvalue(cadr(sc->args))%255;
tinyscheme_genesi... 168 > }
tinyscheme_genesi... 169 > s_return(sc,mk_memblock(sc,len,(char)fill));
tinyscheme_genesi... 170 > }
tinyscheme_genesi... 171 >
tinyscheme_genesi... 172 > case OP_BLOCKLEN: /* block-length */
tinyscheme_genesi... 173 > if(!ismemblock(car(sc->args))) {
tinyscheme_genesi... 174 > Error_1(sc,"block-length: not a memory block:",car(sc->args));
tinyscheme_genesi... 175 > }
tinyscheme_genesi... 176 > s_return(sc,mk_integer(sc,keynum(car(sc->args))));
tinyscheme_genesi... 177 >
tinyscheme_genesi... 178 > case OP_BLOCKREF: { /* block-ref */
tinyscheme_genesi... 179 > char *str;
tinyscheme_genesi... 180 > int index;
tinyscheme_genesi... 181 >
tinyscheme_genesi... 182 > if(!ismemblock(car(sc->args))) {
tinyscheme_genesi... 183 > Error_1(sc,"block-ref: not a memory block:",car(sc->args));
tinyscheme_genesi... 184 > }
tinyscheme_genesi... 185 > str=strvalue(car(sc->args));
tinyscheme_genesi... 186 >
tinyscheme_genesi... 187 > if(cdr(sc->args)==sc->NIL) {
tinyscheme_genesi... 188 > Error_0(sc,"block-ref: needs two arguments");
tinyscheme_genesi... 189 > }
tinyscheme_genesi... 190 > if(!isnumber(cadr(sc->args))) {
tinyscheme_genesi... 191 > Error_1(sc,"block-ref: not a number:",cadr(sc->args));
tinyscheme_genesi... 192 > }
tinyscheme_genesi... 193 > index=ivalue(cadr(sc->args));
tinyscheme_genesi... 194 >
tinyscheme_genesi... 195 > if(index<0 || index>=keynum(car(sc->args))) {
tinyscheme_genesi... 196 > Error_1(sc,"block-ref: out of bounds:",cadr(sc->args));
tinyscheme_genesi... 197 > }
tinyscheme_genesi... 198 >
tinyscheme_genesi... 199 > s_return(sc,mk_integer(sc,str[index]));
tinyscheme_genesi... 200 > }
tinyscheme_genesi... 201 >
tinyscheme_genesi... 202 > case OP_BLOCKSET: { /* block-set! */
tinyscheme_genesi... 203 > char *str;
tinyscheme_genesi... 204 > int index;
tinyscheme_genesi... 205 > int c;
tinyscheme_genesi... 206 >
tinyscheme_genesi... 207 > if(!ismemblock(car(sc->args))) {
tinyscheme_genesi... 208 > Error_1(sc,"block-set!: not a memory block:",car(sc->args));
tinyscheme_genesi... 209 > }
tinyscheme_genesi... 210 > if(isimmutable(car(sc->args))) {
tinyscheme_genesi... 211 > Error_1(sc,"block-set!: unable to alter immutable memory block:",car(sc->args));
tinyscheme_genesi... 212 > }
tinyscheme_genesi... 213 > str=strvalue(car(sc->args));
tinyscheme_genesi... 214 >
tinyscheme_genesi... 215 > if(cdr(sc->args)==sc->NIL) {
tinyscheme_genesi... 216 > Error_0(sc,"block-set!: needs three arguments");
tinyscheme_genesi... 217 > }
tinyscheme_genesi... 218 > if(!isnumber(cadr(sc->args))) {
tinyscheme_genesi... 219 > Error_1(sc,"block-set!: not a number:",cadr(sc->args));
tinyscheme_genesi... 220 > }
tinyscheme_genesi... 221 > index=ivalue(cadr(sc->args));
tinyscheme_genesi... 222 > if(index<0 || index>=keynum(car(sc->args))) {
tinyscheme_genesi... 223 > Error_1(sc,"block-set!: out of bounds:",cadr(sc->args));
tinyscheme_genesi... 224 > }
tinyscheme_genesi... 225 >
tinyscheme_genesi... 226 > if(cddr(sc->args)==sc->NIL) {
tinyscheme_genesi... 227 > Error_0(sc,"block-set!: needs three arguments");
tinyscheme_genesi... 228 > }
tinyscheme_genesi... 229 > if(!isinteger(caddr(sc->args))) {
tinyscheme_genesi... 230 > Error_1(sc,"block-set!: not an integer:",caddr(sc->args));
tinyscheme_genesi... 231 > }
tinyscheme_genesi... 232 > c=ivalue(caddr(sc->args))%255;
tinyscheme_genesi... 233 >
tinyscheme_genesi... 234 > str[index]=(char)c;
tinyscheme_genesi... 235 > s_return(sc,car(sc->args));
tinyscheme_genesi... 236 > }
tinyscheme_genesi... 237
tinyscheme_genesi... 238 Finally, do the same for the predicate in opexe_3.
tinyscheme_genesi... 239
tinyscheme_genesi... 240 | case OP_VECTORP: /* vector? */
tinyscheme_genesi... 241 | s_retbool(is_vector(car(sc->args)));
tinyscheme_genesi... 242 > case OP_BLOCKP: /* block? */
tinyscheme_genesi... 243 > s_retbool(is_memblock(car(sc->args)));
tinyscheme_genesi... 244 | case OP_EQ: /* eq? */