Hello :)
;; First, get the set of required fields in a vtable. There should be a
;; better way for this, but there isn't.
;;
(define vtable-base-layout
(symbol->string (struct-layout (make-vtable ""))))
;; Now make the vtable for record-types. It has the base layout, plus
;; one more field to hold the list of fields in its instances.
;;
(define record-type-vtable
(let ((rtv (make-vtable (string-append vtable-base-layout "pr")
(lambda (x port)
(format port "<record-type ~a ~x>"
(struct-vtable-name x)
(object-address x))))))
(set-struct-vtable-name! rtv 'record-type)
rtv))
;; Each field of a record will be writable. Obviously here we could do
;; "pr" fields instead.
;;
;; fields := NAME...
;;
(define (fields->layout fields)
(apply symbol-append (map (lambda (x) 'pw) fields)))
;; A function to allow us to make new record types. They will be
;; instances of record-type-vtable. They themselves will be vtables.
;;
(define (make-record-type name fields)
(let ((rt (make-struct/no-tail record-type-vtable
(fields->layout fields) ; layout
record-printer ; printer
fields))) ; fields, the 'pr slot
; from above
(set-struct-vtable-name! rt name)
rt))
;; Since fields and names are stored in the vtable, we can access them
;; from a printer.
;;
(define (record-type-name rt)
(struct-vtable-name rt))
(define (record-type-fields rt)
(struct-ref rt vtable-offset-user))
(define (record-printer x port)
(define fields (record-type-fields (struct-vtable x)))
(format port "<~a ~x"
(record-type-name (struct-vtable x))
(object-address x))
(for-each (lambda (f i)
(format port " ~a: ~a" f (struct-ref x i)))
fields (iota (length fields)))
(format port ">"))
;; Record types are instances of record-type-vtable.
;;
(define (record-type? x)
(and (struct? x) (eq? (struct-vtable x) record-type-vtable)))
;; Records are instances of record types. Obviously you could inline
;; record-type? here.
;;
(define (record? x)
(and (struct? x) (record-type? (struct-vtable x))))
;; A little syntax, just to try things out.
(define-syntax define-record-type
(syntax-rules ()
((_ (name make) field ...)
(begin
(define name (make-record-type 'name '(field ...)))
(define (make field ...)
(make-struct/no-tail name field ...))))))
(define-record-type (foo make-foo)
bar baz)
(make-foo 'a 'b)
=> <foo 1ea1a40 bar: a baz: b>
Hope that helps,
Andy
--
http://wingolog.org/
