goops-slot-configuration


This page is a tutorial on class' slot custom configuration for GOOPS, the object oriented extension for Guile. Slots are called data members in other languages: they are the "variables" that hold values in an aggregate data type.

This page deals with version 1.8 of Guile.

Introduction to slots

A GOOPS class definition looks like this:

 (define-module (this-one) 
   #:use-module (oop goops) 
   #:duplicates merge-generics) 
  
 (define-class <triplet> () 
   a b c) 

there are 3 slots identified by the symbols a, b and c; the class can be used like this:

 (define o (make <triplet>)) 
  
 (slot-set o 'b 123) 
 (format #t "the value of b is: ~A~%" (slot-ref o 'b)) 

It is possible use a set of keyword/value couples to add stuff to the slot definition; the most common are: a default value, an initialisation keyword, an accessor. Here is the definition of a single-slot class with all of the above:

 (define-module (this-one) 
   #:use-module (oop goops) 
   #:duplicates merge-generics) 
  
 (define-class <single> () 
   (a #:init-value 123 #:init-keyword #:the-value #:accessor alpha)) 

there is full freedom in the choice of the initialisation keyword and accessor symbols; by no means they are tied to the slot's identifier. The initialisation of the default value is automatic:

 (define o (make <single>)) 
  
 (format #t "the value of 'a' is: ~A~%" (slot-ref o 'a)) 
 ;; -> the value of 'a' is: 123 

the initialisation keyword overrides the default:

 (define o (make <single> 
             #:the-value 456)) 
  
 (format #t "the value of 'a' is: ~A~%" (slot-ref o 'a)) 
 ;; -> the value of 'a' is: 456 

the accessor is a procedure with setter, and is a spiffy (and slower) way to set/get a slot's value:

 (define o (make <single>)) 
  
 (format #t "the value of 'a' is: ~A~%" (alpha o)) 
 ;; -> the value of 'a' is: 123 
  
 (set! (alpha o) 456) 
 (format #t "the value of 'a' is: ~A~%" (alpha o)) 
 ;; -> the value of 'a' is: 456 

It goes without saying, but a class' definition with more than one configured slots looks like this:

 (define-module (this-one) 
   #:use-module (oop goops) 
   #:duplicates merge-generics) 
  
 (define-class <couple> () 
   (a #:init-value 123 #:init-keyword #:alpha #:accessor alpha) 
   (b #:init-value #f #:init-keyword #:beta #:accessor beta)) 

Custom configuration

The easier way to customise a slot's configuration is to use custom keyword/value couples in its specification. The slot specification is the list:

(a #:init-value 123 #:init-keyword #:the-value #:accessor alpha)

adding a custom option means to write something like:

(a #:init-value 123 #:init-keyword #:the-value #:accessor alpha
   #:my-unbelievable-option 'spiffy-value)

Notice that we are free to add any type of crap in a slot's specification, as long as it is a keyword/value couple; GOOPS just ignores couples whose keyword is unrecognised.

To process a custom option we need a hook into the class definition procedure; GOOPS' meta object protocol (MOP) allows this in a number of ways, all of them consist in using a metaclass and adding an appropriate method to a GOOPS' generic function.


Here is an example of metaclass usage that has nothing to do with slot's custom configuration; we know that the instance creation protocol is represented by the method:

 (define-method (make-instance (class <class>) . initargs) 
   (let ((instance (allocate-instance class initargs))) 
     (initialize instance initargs) 
     instance)) 
  
 (define make make-instance) 

to define our own protocol we subclass <class> and add a method to make-instance:

 (define-class <my-class> (<class>)) 
  
 (define-method (make-instance (class <my-class>) . initargs) 
   ;; Here we can do everything, we just have to return an 
   ;; instance of 'class'. 
   ...) 

with the next definition we just print a message and revert to invoking the definition for <class>:

 (define-module (this-one) 
   #:use-module (oop goops) 
   #:duplicates merge-generics) 
  
 (define-class <my-class> (<class>)) 
 (define-method (make-instance (class <my-class>) . initargs) 
   (format #t "instantiating ~A~%" (class-name class)) 
   (next-method)) 
  
 (define-class <spiffy> 
   (a #:init-value 123) 
   #:metaclass <my-class>) 
  
 (define o (make <spiffy>)) ;; this prints the message 
 ;; -> instantiating <spiffy> 
  
 (format #t "the value of 'a' is: ~A~%" (slot-ref o 'a)) 
 ;; -> the value of 'a' is: 123 

Using compute-get-n-set

Among GOOPS' generic functions involved in slots definition, compute-get-n-set is the right one to process custom keyword/value couples. Quoting GOOPS' documentation:

'compute-get-n-set' computes the low-level closures that will be used to
get and set  the value of a  particular slot and returns them  in a list
with two elements.

that is: it computes the two closures invoked by slot-set! and slot-ref. This is not always true: the default method for #:allocation #:instance slots returns the slot's index in the object's struture.

It seems that it has nothing to do with keywords, but the method is invoked once for each slot and with the slot specification as argument; its signature is:

(define-method (compute-get-n-set (class <class>) slot-spec))

so in the body of the method we are free to do whatever we want with the arguments as long as we return the closures. We will see that acting upon the closures is useful, too.


With what we said about metaclasses we should understand what this script does:

 (define-module (this-one) 
   #:use-module (oop goops) 
   #:duplicates merge-generics) 
  
 (define-class <meta-alpha> (<class>)) 
  
 ;;This must be defined before  the definition of the classes that 
 ;;make use of the metaclass. :) 
 (define-method (compute-get-n-set (class <meta-alpha>) slot-spec) 
   (format #t "we are here!!!~%") 
   (next-method)) 
  
 (define-class <alpha> () 
   (a #:init-value #f #:init-keyword #:the-value #:accessor a) 
   #:metaclass <meta-alpha>) 
  
 (define o (make <alpha>)) 
 (set! (a o) 123) 
 (format #t "the slot value is: ~A~%" (a o)) 

this definition of compute-get-n-set prints a message and then reverts to the method defined for <class>.

Notice that compute-get-n-set is invoked while define-class <alpha> ... is going on, not while make is evaluated; so it is invoked only once for each class, and it can act only upon the <alpha> class, not upon the class' instances.


The slot-spec argument is exactly the list:

(a #:init-value #f #:init-keyword #:the-value #:accessor a)

so its car is the slot's identifier a and its cdr is the list of keyword/value couples.

Validating a slot's value

One of the obvious things that we can do is to select a function to be invoked every time a slot is modified: if the new value is invalid, it raises an error. To do this we create custom getter/setter slot's closures:

 (define-module (slot-validator) 
   #:use-module (ice-9 optargs) 
   #:use-module (oop goops) 
   #:duplicates merge-generics) 
  
 ;; ------------------------------------------------------------ 
  
 (define-class <meta-alpha> (<class>)) 
  
 (define-method (compute-get-n-set (class <meta-alpha>) slot-spec) 
   (let-keywords (cdr slot-spec) #t ((validator #f)) 
     (if validator 
         (let ((var #f)) 
           (list (lambda (object) var) 
                 (lambda (object new-value) 
                   (validator object new-value) 
                   (set! var new-value)))) 
       (next-method)))) 
  
 (define-class <alpha> () 
   (a #:init-value #f #:accessor a 
      #:validator (lambda (object new-value) 
                    (assert-number new-value 'a 'slot-set!))) 
   (b #:init-value #f #:accessor b) 
   #:metaclass <meta-alpha>) 
  
 ;; ------------------------------------------------------------ 
  
 (define (assert-number value slot-name procname) 
   (or (number? value) 
       (scm-error 'wrong-type-arg procname 
                  "expected number as '~A' slot's value, got '~S'" 
                  (list slot-name value) #f))) 
  
 (define o (make <alpha>)) 
 (set! (a o) 123) 
 (format #t "the value of 'a' is: ~A~%" (a o)) 
 (catch #t 
   (lambda () 
     (set! (a o) 'too-bad)) 
   (lambda (key procname message msgargs args) 
     (apply format #t message msgargs) 
     (newline))) 
  
 (set! (b o) 'right) 

notice that this solution overrides the setting of the #:allocation keyword.

A weird slot

Here we implement a custom slot to automate this scenario:

 (define-class <this> () 
   a) 
  
 (define-class <that> () 
   b) 
  
 (define this (make <this>)) 
 (define that (make <that>)) 
 (slot-set! this 'a that) 
 (define value (make-object-property)) 
  
 (set! (value that) 123) 
 (define value-fluid     (make-fluid)) 
 (fluid-set! value-fluid value) 
 (define-accessor av) 
 (define-method (av (o <this>)) 
   ((fluid-ref value-fluid) (slot-ref o 'a))) 
 (define-method ((setter av) (o <this>) (v <top>)) 
   (set! ((fluid-ref value-fluid) (slot-ref o 'a)) v)) 
  
 (format #t "the object property is: ~A~%" (av this)) 
 (set! (av this) 456) 
 (format #t "now the object property is: ~A~%" (value that)) 

fatting weird, mh? Believe it or not I (uriel) have a real world usage for this set up (but I am not going to tell you).


Here is the script:

 (define-module (object-property-slot) 
   #:use-module (oop goops) 
   #:use-module (ice-9 optargs) 
   #:duplicates merge-generics) 
  
 ;; ------------------------------------------------------------ 
  
 (define-class <meta-alpha> (<class>)) 
  
 (define-method (compute-get-n-set (class <meta-alpha>) slot-spec) 
   (let-keywords (cdr slot-spec) #t ((value-accessor #f)) 
     (if value-accessor 
         (let ((slot-name (car slot-spec))) 
           (primitive-eval 
            `(begin 
               (define-accessor ,value-accessor) 
               (define-method (,value-accessor (o ,class)) 
                 ((fluid-ref value-fluid) 
                  (slot-ref o ',slot-name))) 
               (define-method ((setter ,value-accessor) 
                               (o ,class) (v <top>)) 
                 (set! ((fluid-ref value-fluid) 
                       (slot-ref o ',slot-name)) v))))))) 
   (next-method)) 
  
 (define-class <alpha> () 
   (a #:accessor a #:value-accessor 'av) 
   #:metaclass <meta-alpha>) 
  
 ;; ------------------------------------------------------------ 
  
 (define value-fluid    (make-fluid)) 
 (define value          (make-object-property)) 
 (fluid-set! value-fluid value) 
  
 (set! (value 'spiffy) 456) 
  
 (with-fluids ((value-fluid value)) 
   (let ((o (make <alpha>))) 
     (set! (a o) 'spiffy) 
     (format #t 
      "the proper slot value, and object with property, is: ~A~%" 
      (a o)) 
     (format #t "the slot's sub value is: ~A~%" (av o)) 
     (set! (av o) 789) 
     (format #t "now the slot's sub value is: ~A~%" (av o)) 
     (format #t "and we can verify it: ~A~%" (value 'spiffy)) 
     (format #t "again: ~A~%" (value (a o))))) 

category-guile|category-goops