The Guile's API for structures allows the creation and handling of vector-like values; there are two reasons for using a special vector value, rather than the standard Scheme vectors:
Guile uses structures to implement high level aggregate data types like records (guile-records) and GOOPS classes.
This page inspects how structures work in Guile version 1.8.
Structures have two purposes:
In the following we name the data-holding structures instances and the format-describing structures vtables.
Each structure has to be associated to a vtable describing its format:
...
|
v
-------- -------- ----------
| vtable |--------------->| vtable |--------------->| instance |
-------- describes the -------- describes the ----------
format of format of
there cannot be infinite chains of vtables, so this implies the existence of vtables that describe the format of themselves:
describes the
format of
-------
| |
v |
-------- |
| root |--- -------- ----------
| vtable |--------------->| vtable |--------------->| instance |
-------- describes the -------- describes the ----------
format of format of
we name these self-describing vtables root vtables. The ring of the root vtable causes no problems because:
It is fine to always use a root vtable for the only purpose of describing the format of a vtable; it is possible, but not mandatory, to use a root vtable to describe the format of an instance.
In complex designs, it is possible to build hierarchies of vtables that piles up to describe the format of an instance. This is what GOOPS does to build hierarchies of classes.
A structure is like a vector accessed with zero-based indexes; the data area is allocated by Guile, internally, and at the Scheme level we use a handle. The internal representation is a C array of machine's words, the array of fields. A handle holds two references: one to the structure's internal representation, the other to the internal representation of the vtable that describes the strucuture's format.
-------------------- | handle/double cell | | | vtable type-describing | ---------------- | internal representation | | reference *-+-+----->|__|__|__|__|__| ... | |----------------| | | | reference *-+-+----->|__|__|__|__|__| ... | ---------------- | structure's internal | | | | representation | |----------------| | | | | | | ---------------- | --------------------
But: while instances only have undifferentiated fields, vtables have two kinds of fields: let's call them system fields and user fields.
To access fields in instances we just use:
(struct-set! instance index value) (struct-ref instance index)
indexes are zero-based.
In vtables: system fields come first, user fields come last.
layout of fields in a vtable
|___|___|___||___|___|___|___|...
0 1 2 3 4 5 6 absolute indexes of fields
0 1 2 indexes of system fields
0 1 2 3 relative indexes of user fields
System fields hold data required by the structure's module to handle vtables. User fields hold data that we can define to fit our needs.
Officially, the number of system fields is unknown (unofficially: it is 3 in Guile version 1.8); but Guile stores the index of the first user field in the variable {{vtable-offset-user}}. So to access user fields by zero-based indexes we can use the following functions:
(define (get-usr-field vtable zero-based-index) (struct-ref vtable (+ vtable-offset-user zero-based-index))) (define (set-usr-field! vtable number value) (struct-set! vtable (+ vtable-offset-user index) value))
or the following macros:
(define-macro (m-get-usr-field vtable zero-based-index) `(struct-ref ,vtable (+ vtable-offset-user ,zero-based-index))) (define-macro (m-set-usr-field! vtable zero-based-index value) `(struct-set! ,vtable (+ vtable-offset-user ,zero-based-index) ,value))
Officially, to access system fields we must use the Guile variables in which proper indexes are stored:
the index of the fields holding the structure format specification (unofficially, the index is 0);
the index of a field that holds the structure's handle itself; it is there to let C language functions access the handle of the structure when only the internal representation of the structure is accessible (unofficially, the index of the self field is 1);
the index of a field in which we can store a function to be used to convert a structure to a string to be shown in debug messages (unofficially, the index is 2); if we do not want to set a function, we just put #f in there and Guile will make use of an internal default function.
A structure's layout is composed of two sections: a fixed-length vector of fields and a tail variable-length array of fields. Let's put the tail array aside for a moment.
A layout is a string of characters, two for each field. The first char selects the type of value, the second char selects the "access protection".
Unfortunately, there is an inconsistency in the Guile's API: there are two functions that take a layout specification as argument, one wants it as a Scheme string while the other wants it as a special symbol. Internally the layout is stored as special symbol.
So for one function "pwpwpw" is the correct value, for the other function we have to do:
(make-struct-layout "pwpwpw")
to build the special symbol.
When inspecting a vtable:
(struct-ref vtable vtable-layout-index)
returns the symbol.
The type chars are:
the field holds a C languge unsigned long value; it is thought that this is the size of the machine's word;
the field holds a Scheme level value, that is a value that is garbage collected;
the field holds the structure's handle itself;
usually we never need to set the type of a field to s; this type exists to let Guile describe properly the layout of vtables.
The access protection chars are:
the field is readable at the Scheme level;
the field is readable and writable at the Scheme level;
the field is opaque at the Scheme level, it cannot be read nor written;
access protection is only for the Scheme level, the C language level can do whatever is needed.
The system fields of vtables are part of a structure's layout. When building a root vtable we do not need to specify them in the string of characters: Guile automatically includes them. We need to specify them when building a second level vtable, more on this later when dealing with differences between instances and vtables.
Let's see some example. When making an instance:
a triplet of garbage collected readable/writable values;
a triplet of garbage collected values, the first read-only the second and third readable/writable;
a pair of values, the first garbage collected and readable/writable, the second an opaque machine's word.
The layout of the system fields of a vtable is prsrpw, for Guile version 1.8:
If we use pwpwpw as the layout when making a new root vtable, Guile will automatically put the layout of the system fields in front of it; so it will become prsrpwpwpwpw.
We are ready to learn how to make a structure; we have to understand how to make: root vtables, vtables, instances. Vtables and instances have the same constructor function, while root vtables have a special constructor. Let's start with root vtables.
The most simple vtable is the one that has no user fields; its format is the empty string "":
(define *type-layout* "") (define *root-vtable* (make-vtable-vtable *type-layout* 0))
make-vtable-vtable makes a root vtable; arguments:
We can inspect the root vtable with:
(format #t "inspection of root vtable: ~S~%" *root-vtable*) (format #t "layout system field:~/ ~S~%" (struct-ref *root-vtable* vtable-index-layout)) (format #t "self system field:~/ ~S~%" (struct-ref *root-vtable* vtable-index-vtable)) (format #t "printer system field:~/ ~S~%" (struct-ref *root-vtable* vtable-index-printer))
the output is:
inspection of root vtable: #<struct 4034feb0:4034feb0> layout system field: prsrpw self system field: #<struct 4034feb0:4034feb0> printer system field: #f
we see the layout of the system fields, the self reference and #f in the field of the printer functions (because we have not specified one). The string #<struct 4034feb0:4034feb0> is the default string representation used by Guile.
Now let's make a root vtable with user fields in the format "pwpw", we also specify a printer function:
(define (printer vtable port) (format port "#<vtable - ~S ~S>" (get-usr-field vtable 0) (get-usr-field vtable 1))) (define *type-layout* "pwpw") (define *root-vtable* (make-vtable-vtable *type-layout* 0 printer))
the first optional argument to make-vtable-vtable is the printer function; we can inspect it with:
(format #t "inspection of root vtable: ~S~%" *root-vtable*) (format #t "layout system field:~/ ~S~%" (struct-ref *root-vtable* vtable-index-layout)) (format #t "self system field:~/ ~S~%" (struct-ref *root-vtable* vtable-index-vtable)) (format #t "printer system field:~/ ~S~%" (struct-ref *root-vtable* vtable-index-printer)) (set-usr-field! *root-vtable* 0 123) (set-usr-field! *root-vtable* 1 456) (format #t "string representation: ~S~%" *root-vtable*)
the output is:
inspection of root vtable: #<vtable - #f #f> layout system field: prsrpwpwpw self system field: #<vtable - #f #f> printer system field: #<procedure printer (vtable port)> first user field: #f second user field: #f string representation: #<vtable - 123 456>
we see that at first the two user fields are initialised with #f, and when we set it the printer function shows them. The printer function in a vtable is used to convert all the structures of the type described by the vtable; a root vtable describes itself, so it holds its own printer function.
Let's build another root vtable with the same layout, but this time we put default values for the user fields in the maker form:
(define *root-vtable*
(make-vtable-vtable *type-layout* 0 printer "abc" "def"))
by applying again the same inspection code we get:
inspection of root vtable: #<vtable - "abc" "def"> layout system field: prsrpwpwpw self system field: #<vtable - "abc" "def"> printer system field: #<procedure printer (vtable port)> first user field: "abc" second user field: "def"
Note that if we want to use the optional arguments to initialise the fields, but we do not want to set a printer function we have to set the argument to #f:
(define *root-vtable* (make-vtable-vtable *type-layout* 0 #f "abc" "def")) ;; ^ ;; | ;; selects the default printer function
Note also that if we use more optional arguments than required:
(define *root-vtable*
(make-vtable-vtable *type-layout* 0 #f "abc" "def" 1 2 3 4))
Guile silently ignores them.
A root vtable with 2 user fields describes vtables with 2 user fields:
(define (vtable-printer vtable port) (format port "#<vtable - ~S ~S>" (get-usr-field vtable 0) (get-usr-field vtable 1))) (define (instance-printer instance port) (format port "#<instance - ~S ~S ~S>" (struct-ref instance 0) (struct-ref instance 1) (struct-ref instance 2))) (define *type-layout* "pwpw") (define *instance-layout* (make-struct-layout "pwpwpw")) (define *root-vtable* (make-vtable-vtable *type-layout* 0 vtable-printer)) (define *type-vtable* (make-struct *root-vtable* 0 *instance-layout* instance-printer))
make-struct makes vtables and instances; arguments:
By applying the following inspection code to the vtable:
(format #t "inspection of type vtable: ~S~%" *type-vtable*) (format #t "derived structures layout field: ~S~%" (struct-ref *type-vtable* vtable-index-layout)) (format #t "self system field: ~S~%" (struct-ref *type-vtable* vtable-index-vtable)) (format #t "printer system field: ~S~%" (struct-ref *type-vtable* vtable-index-printer)) (format #t "first user field: ~S~%" (get-usr-field *type-vtable* 0)) (format #t "second user field: ~S~%" (get-usr-field *type-vtable* 1))
we get:
inspection of type vtable: #<vtable - #f #f> derived structures layout field: pwpwpw self system field: #<vtable - #f #f> printer system field: #<procedure instance-printer (instance port)> first user field: #f second user field: #f
Let's take the same code used before and add the creation of an instance:
(define (vtable-printer vtable port) (format port "#<vtable - ~S ~S>" (get-usr-field vtable 0) (get-usr-field vtable 1))) (define (instance-printer instance port) (format port "#<instance - ~S ~S ~S>" (struct-ref instance 0) (struct-ref instance 1) (struct-ref instance 2))) (define *type-layout* "pwpw") (define *instance-layout* (make-struct-layout "pwpwpw")) (define *root-vtable* (make-vtable-vtable *type-layout* 0 vtable-printer)) (define *type-vtable* (make-struct *root-vtable* 0 *instance-layout* instance-printer)) (define instance (make-struct *type-vtable* 0 123 "abc" #(4 5 6)))
The layout of the instance is defined in *instance-layout*, and it is a triplet of garbage collected values with readable/writable access. The arguments to the make-struct constructor are:
We can inspect the instance with:
(format #t "inspection of instance: ~S~%" instance) (format #t "1st field: ~S~%" (struct-ref instance 0)) (format #t "2nd field: ~S~%" (struct-ref instance 1)) (format #t "3rd field: ~S~%" (struct-ref instance 2))
and get:
inspection of instance: #<instance - 123 "abc" #(4 5 6)> 1st field: 123 2nd field: "abc" 3rd field: #(4 5 6)
With this we have seen enough to use fixed-length structures. Let's try an example.
We want to mimic cons pairs with structures. We implement an equivalent for the functions: cons, car, cdr, set-car!, set-cdr!. Of course this is not a real world example...
The root and type vtables need no fields, while the instance vtable needs two mutable garbage collected fields, one for the car and one for the cdr:
(define *pair-type-layout* "") (define *pair-instance-layout* (make-struct-layout "pwpw"))
the function make-vtable-vtable wants the layout as a string, while non-root vtables require the layout to be symbolified. The vtables are:
(define *pair-root-vtable* (make-vtable-vtable *pair-type-layout* 0)) (define *pair-type-vtable* (make-struct *pair-root-vtable* 0 *pair-instance-layout* pair-instance-printer))
We use a custom function as printer for pair's instances:
(define (pair-instance-printer instance port)
(format port "#<struct-pair - ~A ~A>"
(struct-ref instance 0)
(struct-ref instance 1)))
of course we need to define it before defining *pair-type-vtable*.
The inspection of the root vtable:
(format #t "inspection of struct-pair vtable-vtable ~S~%" *pair-root-vtable*) (format #t "sys field layour: ~S~%" (struct-ref *pair-root-vtable* vtable-index-layout)) (format #t "sys field self: ~S~%" (struct-ref *pair-root-vtable* vtable-index-vtable)) (format #t "sys field printer: ~S~%" (struct-ref *pair-root-vtable* vtable-index-printer))
shows:
inspection of struct-pair vtable-vtable #<struct 4034c440:4034c440> sys field layout: prsrpw sys field self: #<struct 4034c440:4034c440> sys field printer: #f
The inspection of the type vtable:
(format #t "inspection of struct-pair vtable ~S~%" *pair-type-vtable*) (format #t "sys field layout: ~S~%" (struct-ref *pair-type-vtable* vtable-index-layout)) (format #t "sys field self: ~S~%" (struct-ref *pair-type-vtable* vtable-index-vtable)) (format #t "sys field printer: ~S~%" (struct-ref *pair-type-vtable* vtable-index-printer))
shows:
inspection of struct-pair vtable #<struct 4034c440:4034c430> sys field layout: pwpw sys field self: #<struct 4034c440:4034c430> sys field printer: #<procedure pair-instance-printer (instance port)>
The implementation of the functions is pretty simple:
(define (struct:cons a b) (make-struct *pair-type-vtable* 0 a b)) (define (struct:car p) (struct-ref p 0)) (define (struct:cdr p) (struct-ref p 1)) (define (struct:set-car! p v) (struct-set! p 0 v)) (define (struct:set-cdr! p v) (struct-set! p 1 v))
Now we can play it:
(define P (struct:cons #\A #\B)) (format #t "inspection of struct-pair instance ~S~%" P) (format #t "data field 0: ~S~%" (struct-ref P 0)) (format #t "data field 1: ~S~%" (struct-ref P 1)) (newline)
shows:
inspection of struct-pair instance #<struct-pair - A B> data field 0: #\A data field 1: #\B
testing the car and cdr functions:
(format #t "the pair is: ~A, the car is: '~A', the cdr is: '~A'~%" P (struct:car P) (struct:cdr P)) (struct:set-car! P #\C) (struct:set-cdr! P #\D) (format #t "the modified pair is: ~A~%" P)
shows:
the pair is: #<struct-pair - A B>, the car is: 'A', the cdr is: 'B' the modified pair is: #<struct-pair - C D>
And we can chain pairs:
(define Q (struct:cons #\A (struct:cons #\B #\C))) (format #t "the chain of pairs is: ~A~%" Q)
which shows:
the chain of pairs is: #<struct-pair - A #<struct-pair - B C>>
Being made by the same maker: vtables and instances are only semantically different. The struct-vtable? function determines if a structure is a vtable with the following criteria:
So the following:
(define *type-layout* "") (define *instance-layout* (make-struct-layout "pwpwpw")) (define *root-vtable* (make-vtable-vtable *type-layout* 0)) (define *type-vtable* (make-struct *root-vtable* 0 *instance-layout*)) (define instance (make-struct *type-vtable* 0 1 2 3)) (format #t "root vtable is a vtable? ~A~%" (struct-vtable? *root-vtable*)) (format #t "type vtable is a vtable? ~A~%" (struct-vtable? *type-vtable*)) (format #t "instance is a vtable? ~A~%" (struct-vtable? instance))
outputs:
root vtable is a vtable? #t type vtable is a vtable? #t instance is a vtable? #f
which is correct. Notice, though, that there is no check for the correct format of the symbol in the vtable-index-layout field, so we can trick Guile:
(define *type-layout* "") (define *instance-layout* (make-struct-layout "prsrpw")) (define *root-vtable* (make-vtable-vtable *type-layout* 0)) (define *type-vtable* (make-struct *root-vtable* 0 *instance-layout*)) (define instance (make-struct *type-vtable* 0 'whoppa)) (format #t "root vtable is a vtable? ~A~%" (struct-vtable? *root-vtable*)) (format #t "type vtable is a vtable? ~A~%" (struct-vtable? *type-vtable*)) (format #t "instance is a vtable? ~A~%" (struct-vtable? instance))
outputs:
root vtable is a vtable? #t type vtable is a vtable? #t instance is a vtable? #t ;; ^^ ;; !!!!!!!!
It is possible to apply make-struct to a fake-vtable structure, the result is an unusable structure because the format symbol drives the operations of the accessor functions.
So there are perfectly valid instance structures that can be interpreted as vtables. This is a weakness in the structure's module.
What happens if we want to build the following hieararchy?
-----
| |
v |
-------- | -------- --------
| root | | | super | | sub | ----------
| vtable |-+->| vtable |--->| vtable |--->| instance |
-------- -------- -------- ----------
it turns out that we have to do:
(define *type-layout* "prsrpw") (define *super-layout* (make-struct-layout "prsrpwpwpwpw")) (define *instance-layout* (make-struct-layout "pwpwpw")) (define *root-vtable* (make-vtable-vtable *type-layout* 0)) (define *super-vtable* (make-struct *root-vtable* 0 *super-layout*)) (define *sub-vtable* (make-struct *super-vtable* 0 *instance-layout*)) (define instance (make-struct *sub-vtable* 0 1 2 3))
that is: it is our responsibility to put the system fields format, "prsrpw", at the beginning of the sub-vtable layout.
Now let's consider tail arrays. Guile allows us to put an array of fields at the end of a structure's layout at instantiation time. So far we alway put 0, zero, as value of the tail array length in calls to make-struct and make-vtable-vtable.
A tail array is allocated if we use a capitalised char as access protection for the last field of the layout; example pwpW means to allocate an internal representation with:
"pwpW" layout with 5 elements in the array
|___|___||___|___|___|___|___|
0 1 2 3 4 5 6 absolute indexes
0 1 2 3 4 relative array indexes
^ ^
| |
| --------------------------- length-holding field
------------------------------- "pw" field
The length-holding field is automatically inserted, read-only, it is accessed with the normal struct-ref function and does not show up in the layout symbol.
The type of array fields is the same as the last field in the layout:
Example:
(define *type-layout* "") (define *instance-layout* (make-struct-layout "pwpW")) (define *root-vtable* (make-vtable-vtable *type-layout* 0)) (define *type-vtable* (make-struct *root-vtable* 0 *instance-layout*)) (define instance (make-struct *type-vtable* 5 #\A)) (struct-set! instance 4 #\C) (format #t "inspection of instance: ~S~%" instance) (format #t "1st field: ~S~%" (struct-ref instance 0)) (format #t "length of array: ~S~%" (struct-ref instance 1)) (do ((i 0 (1+ i))) ((>= i 5)) (format #t "array element ~A: ~S~%" i (struct-ref instance (+ i 2))))
outputs:
inspection of instance: #<struct 40358a00:403589f0> 1st field: #\A length of array: 5 array element 0: #f array element 1: #f array element 2: #\C array element 3: #f array element 4: #f
If the selected length of the array is zero: the array is not allocated, but the length-holding field is; with the same vtables in the above example:
(define instance (make-struct *type-vtable* 0 #\A)) (format #t "inspection of instance: ~S~%" instance) (format #t "1st field: ~S~%" (struct-ref instance 0)) (format #t "length of array: ~S~%" (struct-ref instance 1))
outputs:
inspection of instance: #<struct 403589a0:40357150> 1st field: #\A length of array: 0
Implementing vectors shows how to use tail arrays. To implement a vector we need a structure that has only the tail array: one field holding the number of elements followed by the array of fields.
The root vtable's layout is the empty string, the type vtable's layout only has the tail array specification:
(define *vector-root-layout* "") (define *vector-instance-layout* (make-struct-layout "pW"))
here are the vtables:
(define *vector-root-vtable* (make-vtable-vtable *vector-root-layout* 0)) (define *vector-type-vtable* (make-struct *vector-root-vtable* 0 *vector-instance-layout* instance-printer-func))
we use a custom printer function:
(define (instance-printer-func instance port)
(let ((len (struct-ref instance 0)))
(format port "#<struct-vector ~A -" len)
(do ((i 1 (1+ i)))
((> i len))
(format port " ~A" (struct-ref instance i)))
(display ">" port)))
that must be defined before the definition of *vector-type-vtable*.
The vector's functions are simple:
(define (struct:make-vector len) (make-struct *vector-type-vtable* len)) (define (struct:vector-length vec) (struct-ref vec 0)) (define (struct:vector-ref vec idx) (struct-ref vec (1+ idx))) (define (struct:vector-set! vec idx val) (struct-set! vec (1+ idx) val))
we only have to acknowledge that the first structure's field holds the vector's length, so we need to increment the user visible index to get
the real element's index. User visible indexes are zero-based.
Now we can play it:
(define o (struct:make-vector 5)) (format #t "the vector is: ~A~%" o) (format #t "the length is: ~A~%" (struct:vector-length o)) (struct:vector-set! o 1 123) (format #t "the 2nd element is: ~A~%" (struct:vector-ref o 1))
outputs:
the vector is: #<struct-vector 5 - #f #f #f #f #f> the length is: 5 the 2nd element is: 123
Guile implements records (guile-records) using structures. Here we implement a record-like module; we call compound our record reimplementation.
With what we have seen so far it should not be difficult to understand the module.
;; compound.scm -- (define-module (compound) #:export (define-compound make-compound make-compound-accessor make-compound-getter-for-slot make-compound-setter-for-slot compound-instance-number-of-slots compound-instance-type compound-inspect-root-vtable compound-inspect-type-vtable compound-inspect-instance)) ;; ------------------------------------------------------------ ;; Vtables field getters. (define (get-usr-field struct number) (struct-ref struct (+ vtable-offset-user number))) ;; ------------------------------------------------------------ (define (compound-vtable-printer-func vtable port) (format port "#<compound-vtable - ~A>" (struct-vtable-name vtable))) ;;Compound vtable fields: list of slot names as symbols. (define *compound-root-layout* "pw") ;;A compound instance is a tail array: one field to hold the ;;number of elements, one for each compound slot. (define *compound-instance-layout* (make-struct-layout "pW")) (define *compound-root-type* (make-vtable-vtable *compound-root-layout* 0 compound-vtable-printer-func)) (set-struct-vtable-name! *compound-root-type* '<compound-root>) ;; ------------------------------------------------------------ (define (compound-instance-number-of-slots instance) (struct-ref instance 0)) (define (compound-instance-type instance) (struct-vtable-name (struct-vtable instance))) (define (compound-instance-list-of-slots instance) (get-usr-field (struct-vtable instance) 0)) ;; ------------------------------------------------------------ (define (compound-vtable-number-of-slots vtable) (length (get-usr-field vtable 0))) ;; ------------------------------------------------------------ (define (compound-instance-printer-func instance port) (format port "#<compound ~A -" (compound-instance-type instance)) (let ((number-of-slots (compound-instance-number-of-slots instance))) (do ((i 1 (1+ i))) ((> i number-of-slots)) (format port " ~A" (struct-ref instance i)))) (display ">" port)) (define-macro (define-compound type-name list-of-slots) (let ((compound-type (make-struct *compound-root-type* 0 *compound-instance-layout* compound-instance-printer-func list-of-slots))) (set-struct-vtable-name! compound-type type-name) `(begin (define ,type-name ,compound-type)))) (define (make-compound vtable) (make-struct vtable (length (get-usr-field vtable 0)))) ;; ------------------------------------------------------------ (define (compound-inspect-root-vtable) (format #t "inspection of compound root vtable ~S~%" *compound-root-type*) (format #t "sys field layout: ~S~%" (struct-ref *compound-root-type* vtable-index-layout)) (format #t "sys field self: ~S~%" (struct-ref *compound-root-type* vtable-index-vtable)) (format #t "sys field printer: ~S~%" (struct-ref *compound-root-type* vtable-index-printer)) (format #t "usr field 0: ~S~%~%" (get-usr-field *compound-root-type* 0))) (define (compound-inspect-type-vtable vtable) (format #t "inspection of compound vtable ~S~%" vtable) (format #t "sys field layout: ~S~%" (struct-ref vtable vtable-index-layout)) (format #t "sys field self: ~S~%" (struct-ref vtable vtable-index-vtable)) (format #t "sys field printer: ~S~%" (struct-ref vtable vtable-index-printer)) (format #t "usr field 0: ~S~%~%" (get-usr-field vtable 0))) (define (compound-inspect-instance instance) (format #t "inspection of compound ~S~%class: ~S, number of slots: ~S~%" instance (compound-instance-type instance) (compound-instance-number-of-slots instance)) (let loop ((list-of-slots (compound-instance-list-of-slots instance)) (index-of-next-slot 1)) (format #t "slot '~A':~/~A~%" (car list-of-slots) (struct-ref instance index-of-next-slot)) (if (not (null? (cdr list-of-slots))) (loop (cdr list-of-slots) (1+ index-of-next-slot)))) (newline)) ;; ------------------------------------------------------------ (define (find-slot-index-in-list slot-name list-of-slots) (let loop ((idx 0) (ell list-of-slots)) (if (eq? slot-name (car ell)) ;;Increment by 1 to skip the length of the tail array. (1+ idx) (loop (1+ idx) (cdr ell))))) (define (make-compound-getter-for-slot vtable slot-name) (let* ((list-of-slots (get-usr-field vtable 0)) (index-of-slot (find-slot-index-in-list slot-name list-of-slots))) ;;Use QUASIQUOTE so that we do not close upon this ;;local environment. (primitive-eval `(lambda (instance) (struct-ref instance ,index-of-slot))))) (define (make-compound-setter-for-slot vtable slot-name) (let* ((list-of-slots (get-usr-field vtable 0)) (index-of-slot (find-slot-index-in-list slot-name list-of-slots))) ;;Use QUASIQUOTE so that we do not close upon this ;;local environment. (primitive-eval `(lambda (instance value) (struct-set! instance ,index-of-slot value))))) (define (make-compound-accessor vtable slot-name) (make-procedure-with-setter (make-compound-getter-for-slot vtable slot-name) (make-compound-setter-for-slot vtable slot-name))) ;;; end of file
A little test:
(define-compound <person> (name surname phone)) (compound-inspect-root-vtable) (compound-inspect-type-vtable <person>) (define (make-person name surname phone) (let ((instance (make-compound <person>))) ;;The index 0 field is the length of the tail array. (struct-set! instance 1 name) (struct-set! instance 2 surname) (struct-set! instance 3 phone) instance)) (define person-name (make-compound-accessor <person> 'name)) (define P (make-person "john" "doe" "1234")) (compound-inspect-instance P) (format #t "the <person> instance is: ~A~%" P) (format #t "the 'name' slot is: ~A~%" (person-name P)) (set! (person-name P) "paul") (format #t "after modifying the 'name' slot is: ~A~%" (person-name P))
outputs:
inspection of compound root vtable #<compound-vtable - <compound-root>> sys field 0: prsrpwpw sys field 1: #<compound-vtable - <compound-root>> sys field 2: #<procedure compound-vtable-printer-func (vtable port)> usr field 0: #f inspection of compound vtable #<compound-vtable - <person>> sys field 0: pW sys field 1: #<compound-vtable - <person>> sys field 2: #<procedure compound-instance-printer-func (instance port)> usr field 0: (name surname phone) inspection of compound #<compound <person> - john doe 1234> class: <person>, number of slots: 3 slot 'name': john slot 'surname': doe slot 'phone': 1234 the <person> instance is: #<compound <person> - john doe 1234> the 'name' slot is: john after modifying the 'name' slot is: paul