Guile Reference Manual: Vtable Example

Let us bring these points together with an example. Consider a simple object system with single inheritance. Objects will be normal structures, and classes will be vtables with three extra class fields: the name of the class, the parent class, and the list of fields.

So, first we need a meta-vtable that allocates instances with these extra class fields.

(define <class>
  (make-vtable
   (string-append standard-vtable-fields "pwpwpw")
   (lambda (x port)
     (format port "<<class> ~a>" (class-name x)))))

(define (class? x)
  (and (struct? x)
       (eq? (struct-vtable x) <class>)))

To make a structure with a specific meta-vtable, we will use make-struct/no-tail, passing it the computed instance layout and printer, as with make-vtable, and additionally the extra three class fields.

(define (make-class name parent fields)
  (let* ((fields (compute-fields parent fields))
         (layout (compute-layout fields)))
    (make-struct/no-tail <class>
      layout 
      (lambda (x port)
        (print-instance x port))
      name
      parent
      fields)))

Instances will store their associated data in slots in the structure: as many slots as there are fields. The compute-layout procedure below can compute a layout, and field-index returns the slot corresponding to a field.

(define-syntax-rule (define-accessor name n)
  (define (name obj)
    (struct-ref obj n)))

;; Accessors for classes
(define-accessor class-name (+ vtable-offset-user 0))
(define-accessor class-parent (+ vtable-offset-user 1))
(define-accessor class-fields (+ vtable-offset-user 2))

(define (compute-fields parent fields)
  (if parent
      (append (class-fields parent) fields)
      fields))

(define (compute-layout fields)
  (make-struct-layout
   (string-concatenate (make-list (length fields) "pw"))))

(define (field-index class field)
  (list-index (class-fields class) field))

(define (print-instance x port)
  (format port "<~a" (class-name (struct-vtable x)))
  (for-each (lambda (field idx)
              (format port " ~a: ~a" field (struct-ref x idx)))
            (class-fields (struct-vtable x))
            (iota (length (class-fields (struct-vtable x)))))
  (format port ">"))

(define-syntax-rule (define-class name parent field ...)
  (define name (make-class 'name parent '(field ...))))

(define-class <surface> #f
  width height)

(define-class <window> <surface>
  x y)

(make-struct/no-tail <window> 400 300 10 20)
⇒ <<window> width: 400 height: 300 x: 10 y: 20>

And that’s that. Note that there are many possible optimizations and feature enhancements that can be made to this object system, and the included GOOPS system does make most of them. For more simple use cases, the records facility is usually sufficient. But sometimes you need to make new kinds of data abstractions, and for that purpose, structs are here.

6.7.10.5 Vtable Example