[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Re: Problems with field initialization: Proposal

This page is part of the web mail archives of SRFI 76 from before July 7th, 2015. The new archives for SRFI 76 contain all messages, not just those from before July 7th, 2015.



On Tue, 20 Sep 2005, Michael Sperber wrote:


Andre van Tonder <andre@xxxxxxxxxxxxxxxxxxx> 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)