mirror of https://github.com/GNOME/gimp.git
237 lines
8.3 KiB
Plaintext
237 lines
8.3 KiB
Plaintext
|
|
How to hack TinyScheme
|
|
----------------------
|
|
|
|
TinyScheme is easy to learn and modify. It is structured like a
|
|
meta-interpreter, only it is written in C. All data are Scheme
|
|
objects, which facilitates both understanding/modifying the
|
|
code and reifying the interpreter workings.
|
|
|
|
In place of a dry description, we will pace through the addition
|
|
of a useful new datatype: garbage-collected memory blocks.
|
|
The interface will be:
|
|
|
|
(make-block <n> [<fill>]) makes a new block of the specified size
|
|
optionally filling it with a specified byte
|
|
(block? <obj>)
|
|
(block-length <block>)
|
|
(block-ref <block> <index>) retrieves byte at location
|
|
(block-set! <block> <index> <byte>) modifies byte at location
|
|
|
|
In the sequel, lines that begin with '>' denote lines to add to the
|
|
code. Lines that begin with '|' are just citations of existing code.
|
|
|
|
First of all, we need to assign a typeid to our new type. Typeids
|
|
in TinyScheme are small integers declared in an enum, very close to
|
|
the top; it begins with T_STRING. Add a new one at the end, say
|
|
T_MEMBLOCK. There can be at most 31 types, but you don't have to
|
|
worry about that limit yet.
|
|
|
|
| ...
|
|
| T_PORT,
|
|
| T_VECTOR, /* remember to add a comma to the preceding item! */
|
|
| T_MEMBLOCK
|
|
} };
|
|
|
|
Then, some helper macros would be useful. Go to where isstring() and
|
|
the rest are defined and define:
|
|
|
|
> int ismemblock(pointer p) { return (type(p)==T_MEMBLOCK); }
|
|
|
|
This actually is a function, because it is meant to be exported by
|
|
scheme.h. If no foreign function will ever manipulate a memory block,
|
|
you can instead define it as a macro
|
|
|
|
> #define ismemblock(p) (type(p)==T_MEMBLOCK)
|
|
|
|
Then we make space for the new type in the main data structure:
|
|
struct cell. As it happens, the _string part of the union _object
|
|
(that is used to hold character strings) has two fields that suit us:
|
|
|
|
| struct {
|
|
| char *_svalue;
|
|
| int _keynum;
|
|
| } _string;
|
|
|
|
We can use _svalue to hold the actual pointer and _keynum to hold its
|
|
length. If we couln't reuse existing fields, we could always add other
|
|
alternatives in union _object.
|
|
|
|
We then procede to write the function that actually makes a new block.
|
|
For conformance reasons, we name it mk_memblock
|
|
|
|
> static pointer mk_memblock(scheme *sc, int len, char fill) {
|
|
> pointer x;
|
|
> char *p=(char*)sc->malloc(len);
|
|
>
|
|
> if(p==0) {
|
|
> return sc->NIL;
|
|
> }
|
|
> x = get_cell(sc, sc->NIL, sc->NIL);
|
|
>
|
|
> typeflag(x) = T_MEMBLOCK|T_ATOM;
|
|
> strvalue(x)=p;
|
|
> keynum(x)=len;
|
|
> memset(p,fill,len);
|
|
> return (x);
|
|
> }
|
|
|
|
The memory used by the MEMBLOCK will have to be freed when the cell
|
|
is reclaimed during garbage collection. There is a placeholder for
|
|
that staff, function finalize_cell(), currently handling strings only.
|
|
|
|
| static void finalize_cell(scheme *sc, pointer a) {
|
|
| if(isstring(a)) {
|
|
| sc->free(strvalue(a));
|
|
| }
|
|
> else if(ismemblock(a)) {
|
|
> sc->free(strvalue(x));
|
|
> }
|
|
| }
|
|
|
|
There are no MEMBLOCK literals, so we don't concern ourselfs with
|
|
the READER part (yet!). We must cater to the PRINTER, though. We
|
|
add one case more in printatom().
|
|
|
|
| } else if (iscontinuation(l)) {
|
|
| p = "#<CONTINUATION>";
|
|
> } else if (ismemblock(l)) {
|
|
> p = "#<MEMORY BLOCK>";
|
|
| }
|
|
|
|
Whenever a MEMBLOCK is displayed, it will look like that.
|
|
Now, we must add the interface functions: constructor, predicate,
|
|
accessor, modifier. We must in fact create new op-codes for the virtual
|
|
machine underlying TinyScheme. There is a huge enum with OP_XXX values.
|
|
That's where the op-codes are declared. For reasons of cohesion, we add
|
|
the new op-codes right after those for vectors:
|
|
|
|
| OP_VECSET,
|
|
> OP_MKBLOCK,
|
|
> OP_MEMBLOCKP,
|
|
> OP_BLOCKLEN,
|
|
> OP_BLOCKREF,
|
|
> OP_BLOCKSET,
|
|
| OP_NOT,
|
|
|
|
We add the predicate along the other predicates:
|
|
|
|
| OP_VECTORP,
|
|
> OP_BLOCKP,
|
|
| OP_EQ,
|
|
|
|
Op-codes are really just tags for a huge C switch, only this switch
|
|
is broke up in a number of different opexe_X functions. The
|
|
correspondence is made in table "dispatch_table". There, we assign
|
|
the new op-codes to opexe_2, where the equivalent ones for vectors
|
|
are situated. We also assign a name for them, and specify the minimum
|
|
and maximum arity. INF_ARG as a maximum arity means "unlimited".
|
|
|
|
| {opexe_2, "vector-set!", 3, 3}, /* OP_VECSET */
|
|
> {opexe_2, "make-block", 1, 2}, /* OP_MKBLOCK */
|
|
> {opexe_2, "block-length", 1, 1}, /* OP_BLOCKLEN */
|
|
> {opexe_2, "block-ref", 2, 2}, /* OP_BLOCKREF */
|
|
> {opexe_2, "block-set!",3 ,3}, /* OP_BLOCKSET */
|
|
|
|
The predicate goes with the other predicates, in opexe_3.
|
|
|
|
| {opexe_3, "vector?", 1, 1}, /* OP_VECTORP, */
|
|
> {opexe_3, "block?", 1, 1}, /* OP_BLOCKP, */
|
|
|
|
All that remains is to write the actual processing in opexe_2, right
|
|
after OP_VECSET.
|
|
|
|
> case OP_MKBLOCK: { /* make-block */
|
|
> int fill=0;
|
|
> int len;
|
|
>
|
|
> if(!isnumber(car(sc->args))) {
|
|
> Error_1(sc,"make-block: not a number:",car(sc->args));
|
|
> }
|
|
> len=ivalue(car(sc->args));
|
|
> if(len<=0) {
|
|
> Error_1(sc,"make-block: not positive:",car(sc->args));
|
|
> }
|
|
>
|
|
> if(cdr(sc->args)!=sc->NIL) {
|
|
> if(!isnumber(cadr(sc->args)) || ivalue(cadr(sc->args))<0) {
|
|
> Error_1(sc,"make-block: not a positive number:",cadr(sc->args));
|
|
> }
|
|
> fill=charvalue(cadr(sc->args))%255;
|
|
> }
|
|
> s_return(sc,mk_memblock(sc,len,(char)fill));
|
|
> }
|
|
>
|
|
> case OP_BLOCKLEN: /* block-length */
|
|
> if(!ismemblock(car(sc->args))) {
|
|
> Error_1(sc,"block-length: not a memory block:",car(sc->args));
|
|
> }
|
|
> s_return(sc,mk_integer(sc,keynum(car(sc->args))));
|
|
>
|
|
> case OP_BLOCKREF: { /* block-ref */
|
|
> char *str;
|
|
> int index;
|
|
>
|
|
> if(!ismemblock(car(sc->args))) {
|
|
> Error_1(sc,"block-ref: not a memory block:",car(sc->args));
|
|
> }
|
|
> str=strvalue(car(sc->args));
|
|
>
|
|
> if(cdr(sc->args)==sc->NIL) {
|
|
> Error_0(sc,"block-ref: needs two arguments");
|
|
> }
|
|
> if(!isnumber(cadr(sc->args))) {
|
|
> Error_1(sc,"block-ref: not a number:",cadr(sc->args));
|
|
> }
|
|
> index=ivalue(cadr(sc->args));
|
|
>
|
|
> if(index<0 || index>=keynum(car(sc->args))) {
|
|
> Error_1(sc,"block-ref: out of bounds:",cadr(sc->args));
|
|
> }
|
|
>
|
|
> s_return(sc,mk_integer(sc,str[index]));
|
|
> }
|
|
>
|
|
> case OP_BLOCKSET: { /* block-set! */
|
|
> char *str;
|
|
> int index;
|
|
> int c;
|
|
>
|
|
> if(!ismemblock(car(sc->args))) {
|
|
> Error_1(sc,"block-set!: not a memory block:",car(sc->args));
|
|
> }
|
|
> if(isimmutable(car(sc->args))) {
|
|
> Error_1(sc,"block-set!: unable to alter immutable memory block:",car(sc->args));
|
|
> }
|
|
> str=strvalue(car(sc->args));
|
|
>
|
|
> if(cdr(sc->args)==sc->NIL) {
|
|
> Error_0(sc,"block-set!: needs three arguments");
|
|
> }
|
|
> if(!isnumber(cadr(sc->args))) {
|
|
> Error_1(sc,"block-set!: not a number:",cadr(sc->args));
|
|
> }
|
|
> index=ivalue(cadr(sc->args));
|
|
> if(index<0 || index>=keynum(car(sc->args))) {
|
|
> Error_1(sc,"block-set!: out of bounds:",cadr(sc->args));
|
|
> }
|
|
>
|
|
> if(cddr(sc->args)==sc->NIL) {
|
|
> Error_0(sc,"block-set!: needs three arguments");
|
|
> }
|
|
> if(!isinteger(caddr(sc->args))) {
|
|
> Error_1(sc,"block-set!: not an integer:",caddr(sc->args));
|
|
> }
|
|
> c=ivalue(caddr(sc->args))%255;
|
|
>
|
|
> str[index]=(char)c;
|
|
> s_return(sc,car(sc->args));
|
|
> }
|
|
|
|
Same for the predicate in opexe_3.
|
|
|
|
| case OP_VECTORP: /* vector? */
|
|
| s_retbool(isvector(car(sc->args)));
|
|
> case OP_BLOCKP: /* block? */
|
|
> s_retbool(ismemblock(car(sc->args)));
|