make-vtable-vtable

[Thien-Thi Nguyen]

someone asked about alternatives for smobs and i suggested looking
into structs w/o understanding them very well at the time.  this
prompted me to delve into them a little, including looking at the
docs.  turns out, docs for make-vtable-vtable are incorrect (as
well as unreviewed :-).

vtable fields (w/ non-negative index numbers -- see struct.h) are:

 0 -- memory layout string
 1 -- opaque (for gc)
 2 -- printer callback
 3 -- "user offset" (conventionally a symbol naming the type)

make-vtable-vtable args are new-fields, tail-size, and inits.
new-fields and tail-size args update field 0.  field 1 is under
internal control.  inits start with field 2.  thus, to get the
desired behavior of

          (struct-ref x vtable-offset-user)
          => foo

that is, vtable's "vtable-offset-user" field naming the type,
the example should be changed from

          (define x
            (make-vtable-vtable (make-struct-layout (quote pw))
                                0
                                'foo))

to

          (define x
            (make-vtable-vtable (make-struct-layout (quote pw))
                                0
                                #f              ;; new
                                'foo))

likewise, the definition for `y' should be updated to:

          (define y
            (make-struct x
                         0
                         (make-struct-layout (quote pwpwpw))
                         #f                     ;; new
                         'bar))

below is a nascent structures.test; feedback welcome.  i think it
would be nice to find/write a tutorial comparing/contrasting
structures and smobs: usage, tips, performance, philosophy, etc.
an interesting test case would be libbfd + bit-field-diagram +
structures and/or smobs.

thi


___________________________________________________________________________
;;; structures.test                                     -*- scheme -*-

;;      Copyright (C) 2002 Free Software Foundation, Inc.
;;
;; This file is part of GUILE [... deletia ...]

;;; Author: Thien-Thi Nguyen <address@hidden>

(pass-if "structures procs"
  (and make-struct-layout (procedure? make-struct-layout)
       make-struct (procedure? make-struct)
       struct? (procedure? struct?)
       struct-ref (procedure? struct-ref)
       struct-set! (procedure? struct-set!)
       struct-vtable (procedure? struct-vtable)
       struct-vtable? (procedure? struct-vtable?)
       make-vtable-vtable (procedure? make-vtable-vtable)
       struct-vtable-name (procedure? struct-vtable-name)
       set-struct-vtable-name! (procedure? set-struct-vtable-name!)
       struct-vtable-tag (procedure? struct-vtable-tag)))

(define structures-test:exception:ref-denied
  (cons 'misc-error "ref denied"))

;; TODO: test this, too.
;;+ (define structures-test:exception:set!-denied
;;+   (cons 'misc-error "set_x denied"))

;; chaining state

(define structures-test:x #f)
(define structures-test:y #f)

;; tests

(with-test-prefix "make-vtable-vtable"
  (let ((x (make-vtable-vtable (make-struct-layout (quote pw))
                               0
                               #f       ; printer callback
                               'foo)))  ; name
    (pass-if "x" (->bool x))
    (pass-if "struct?" (struct? x))
    (pass-if "struct-vtable?" (struct-vtable? x))
    (pass-if "points to self" (eq? x (struct-vtable x)))
    (pass-if "user offset holds name"
      (eq? 'foo (struct-ref x vtable-offset-user)))

    ;; ref checks
    (pass-if-exception "ref -1 is out-of-range"
      exception:out-of-range
      (struct-ref x -1))
    (pass-if "ref 0 is layout"
      (let ((ref-0 (struct-ref x 0)))
        (and (symbol? ref-0)
             ;; symbol specially interned so compare as string
             (string=? "pruosrpwpw" (symbol->string ref-0)))))
    (pass-if-exception "ref 1 opaque"
      structures-test:exception:ref-denied
      (struct-ref x 1))
    (pass-if "ref 2 is pointer to handle (self)"
      (let ((ref-2 (struct-ref x 2)))
        (and ref-2 (eq? x ref-2 (struct-vtable x)))))
    (pass-if "ref 3 is printer for this type"
      (not (struct-ref x 3)))
    (pass-if "ref 4 is name"
      (eq? 'foo (struct-ref x 4)))
    (pass-if-exception "ref 5 is out-of-range"
      exception:out-of-range
      (struct-ref x 5))

    ;; chain
    (set! structures-test:x x)))

(with-test-prefix "make vtable (using make-struct)"
  (let* ((x structures-test:x)
         (y (make-struct x 0
                         (make-struct-layout (quote pwpwpw))
                         #f
                         'bar)))
    (pass-if "y" (->bool y))
    (pass-if "struct?" (struct? y))
    (pass-if "struct-vtable?" (struct-vtable? y))
    (pass-if "x and y not eq" (not (eq? x y)))
    (pass-if "x is y's vtable" (eq? x (struct-vtable y)))
    (pass-if "user offset holds name"
      (eq? 'bar (struct-ref y vtable-offset-user)))

    ;; ref checks
    (pass-if-exception "ref -1 is out-of-range"
      exception:out-of-range
      (struct-ref y -1))
    (pass-if "ref 0 is layout"
      (let ((ref-0 (struct-ref y 0)))
        (and (symbol? ref-0)
             ;; symbol specially interned so compare as strings
             (string=? "pwpwpw" (symbol->string ref-0)))))
    (pass-if-exception "ref 1 is opaque"
      structures-test:exception:ref-denied
      (struct-ref y 1))
    (pass-if "ref 2 is pointer to handle (self)"
      (let ((ref-2 (struct-ref y 2)))
        (and ref-2 (eq? y ref-2))))
    (pass-if "ref 3 is printer for this type"
      (not (struct-ref y 3)))
    (pass-if "ref 4 is name"
      (eq? 'bar (struct-ref y 4)))
    (pass-if-exception "ref 5 is out-of-range"
      exception:out-of-range
      (struct-ref y 5))

    ;; chain
    (set! structures-test:y y)))

(with-test-prefix "make structure (using make-struct)"
  (let* ((x structures-test:x)
         (y structures-test:y)
         (z (make-struct y 0 'a 'b 'c)))
    (pass-if "z" (->bool z))
    (pass-if "struct?" (struct? z))
    (pass-if "not struct-vtable?" (not (struct-vtable? z)))
    (pass-if "y is z's vtable" (eq? y (struct-vtable z)))
    (pass-if-exception "ref -1 out-of-range"
      exception:out-of-range
      (struct-ref z -1))
    (pass-if "ref 0-2" (equal? '(a b c)
                               (map (lambda (n)
                                      (struct-ref z n))
                                    '(0 1 2))))
    (pass-if-exception "ref 3 out-of-range"
      exception:out-of-range
      (struct-ref z 3))))

;;; structures.test ends here