On Tue, 20 Sep 2005, Michael Sperber wrote:

>
> Andre van Tonder <xxxxxx@later.het.brown.edu> writes:
>
>>    (define-type rational (x y)
>>      (let ((common (gcd x y)))
>>        (field-values
>>          (num   (/ x common))
>>          (denom (/ y common))))
>>      (fields (num   (rational-num))
>>              (denom (rational-denom))))
>
> Could you elaborate on how the general mechanism would work?  I.e. is
> there a special syntax for the (let ...) stuff, or is it general
> Scheme, with FIELD-VALUES being a special form?

Below is a very rough and ugly code fragment (MzScheme) that implements the
inner workings, though not the surface syntax, of this idea.  More examples are
at the end.

In the following examples, INSTANTIATE is a local lexical macro valid in the
constructor clause that does two orthogonal things:

- It maps field names to positions.
- It has an implicit argument, a version of the subtype constructor already
   curried with the subtype field values.  It then further stages the inclusion
   of the current fields and the invocation of the supertype constructor.

The return value of INSTANTIATE is a record value of the appropriate /subtype/.
As a result, a separate INIT! is unnecessary.

In the following examples, both the formals and the parent arguments can easily
be factored out to reproduce the surface syntax of the SRFI, with a certain loss
of expressiveness.

   (define-type (rational make-rational)
     (parent #f)
     (fields (num   immutable)
             (denom immutable))
     (constructor (lambda (x y)
                    (if (= y 0)
                        (instantiate ()
                          (num   1)
                          (denom 0))
                        (let ((common (gcd x y)))
                          (instantiate ()
                           (num   (/ x common))
                           (denom (/ y common))))))))

   (define-type (hash-table make-hash-table)
     (parent #f)
     (fields (pred   immutable)
             (hasher immutable)
             (data   mutable)
             (count  mutable 0))
     (constructor (lambda (pred hasher size)
                    (instantiate ()
                      (pred   pred)
                      (hasher hasher)
                      (data   (make-vector size))))))

   (define-type (eq-hash-table make-eq-hash-table)
     (parent hash-table)
     (fields (gc-count mutable 0))
     (constructor (lambda (pred hasher size)
                    (instantiate (pred hasher size)))))

Cheers
Andre

;===================================================
;
; Implementation:
;
;===================================================

(begin-for-syntax

   (define registry '())

   (define (register type)
     (set! registry
           (cons (cons (syntax-object->datum (car type))
                       (cdr type))
                 registry)))

   (define (lookup type-name)
     (assq (syntax-object->datum type-name) registry))

   (define type-constructor       cadr)
   (define type-parent            caddr)
   (define type-fields            cadddr)
   (define (type-constructor-k t) (car (cddddr t)))

   (define (order init-list type-name)
     (let ((fields (map syntax->list (syntax->list (type-fields (lookup
type-name)))))
           (init-list (map (lambda (elem)
                             (let ((elem (syntax->list elem)))
                               (cons (syntax-object->datum (car elem))
                                     (cdr elem))))
                           (syntax->list init-list))))
       (map (lambda (field)
              (cond ((assq (syntax-object->datum (car field)) init-list) => cadr)
                    (else (if (= (length field) 3)
                              (caddr field)
                              (raise-syntax-error #f "Uninitialized field: " (car
field))))))
            fields)))

   ) ; begin-for-syntax

(define (make-object-k k)
   (lambda ()
     (k '())))

(define-syntax define-type
    (lambda (form)
      (syntax-case form (parent fields constructor)
        ((_ (t make-t)
            (parent p)
            (fields f ...)
            (constructor proc))
         (with-syntax ((make-t-k (datum->syntax-object (syntax t) (gensym
'make-t-k)))) ; gensym needed due to bug in MzScheme
           (begin
             (register (list (syntax t)
                             (syntax make-t)
                             (syntax p)
                             (syntax (f ...))
                             (syntax make-t-k)))
             (with-syntax ((parent-constructor-k
                            (cond ((lookup (syntax p)) => type-constructor-k)
                                  (else
                                   (syntax make-object-k))))
                           (instantiate
                               (datum->syntax-object (syntax t) 'instantiate)))
               (syntax
                (begin
                  (define make-t-k
                    (lambda (k)
                      (let-syntax ((instantiate
                                       (lambda (form)
                                         (syntax-case form ()
                                           ((_ parent-fields . fields)
                                            (quasisyntax
                                             ((parent-constructor-k
                                               (lambda (super-fields)
                                                 (k (append super-fields (list .
#,(order (syntax fields) (syntax t)))))))
                                              . parent-fields)))))))
                        proc)))
                  (define make-t (make-t-k (lambda (fields) (cons 't
fields)))))))))))))

(define-type (point make-point)
   (parent #f)
   (fields (x immutable)
           (y immutable)
           (remark immutable 'hello))
   (constructor (lambda (x y)
                  (instantiate ()
                    (x (/ x))
                    (y (/ y))))))

(make-point 1 2)

(define-type (cpoint make-cpoint)
   (parent point)
   (fields (color immutable 'white))
   (constructor (lambda (x y c)
                  (instantiate (x y)
                    (color c)))))

(make-cpoint 1 2 'blu)

(define-type (hash-table make-hash-table)
   (parent #f)
   (fields (pred   immutable)
           (hasher immutable)
           (data   mutable)
           (count  mutable 0))
   (constructor (lambda (pred hasher size)
                  (instantiate ()
                    (pred   pred)
                    (hasher hasher)
                    (data   (make-vector size))))))

(make-hash-table eq? #f 5)

(define-type (eq-hash-table make-eq-hash-table)
   (parent hash-table)
   (fields (gc-count mutable 0))
   (constructor (lambda (pred hasher size)
                  (instantiate (pred hasher size)))))

(make-eq-hash-table eq? #f 5)

(define-type (rational make-rational)
   (parent #f)
   (fields (num   immutable)
           (denom immutable))
   (constructor (lambda (x y)
                  (if (= y 0)
                      (instantiate ()
                        (num   1)
                        (denom 0))
                      (let ((common (gcd x y)))
                        (instantiate ()
                         (num   (/ x common))
                         (denom (/ y common))))))))

(make-rational 4 8)