Re: Update available-- possibly last before finalization

[Felix Winkelmann <fw@xxxxxxxxx>]

Andre van Tonder wrote:
> On Fri, 10 Dec 2004, Felix Winkelmann wrote:
>
> > From what my experiments show the current SRFI-57 reference 
> > implementation
> > does *not* work on systems that provide a non-generative SRFI-9, or non-
> > generative native records.
>
>
> I'm not sure why that should be.  Would you mind saying a bit more on this?

[This has been tested on Chicken only]

Here a simple implementation of SRFI-9, using syntax-case:


(define <record> (list 'vector))

(define-syntax (srfi-9:define-record-type x)
  (define (memi id ids)
    (and (not (null? ids))
	 (or (free-identifier=? id (car ids))
	     (memi id (cdr ids)) ) ) )
  (syntax-case x ()
    [(_ t (conser vars ...) pred slots ...)
     (syntax-case #'(slots ...) ()
       [((slotnames . _) ...)
	(with-syntax ([(slotvars ...) (map (lambda (sname)
					     (if (memi sname #'(vars ...))
						 sname
						 #'(void) ) )
					   #'(slotnames ...)) ] )
	  (with-syntax ([(accforms ...)
			 (let loop ([slots #'(slots ...)] [i 2])
			   (if (null? slots)
			       #'()
			       (with-syntax ([ii i]
					     [(rest ...) (loop (cdr slots) (+ 1 i))] )
				 (syntax-case (car slots) ()
				   [(name get set)
				    #'((define (get x)
					 (vector-ref x ii) )
				       (define (set x y)
					 (vector-set! x ii y) )
				       rest ...) ]
				   [(name get)
				    #'((define (get x)
					 (vector-ref x ii) )
				       rest ...) ] ) ) ) ) ] )
	    #'(begin
		(define t 't)
		(define (conser vars ...) (vector <record> 't slotvars ...))
		(define (pred x) (and (vector? x) (eq? <record> (vector-ref x 0))))
		accforms ...) ) ) ] ) ] ) )


(note that the tag of the record vector is "'t")
And here is what I get when I run everything in the interpreter:


#;1> ,l srfi-57
; loading srfi-57.scm ...
#;1> (load-noisily "srfi-57-test.scm" printer: pp)
; loading srfi-57-test.scm ...
(define-record-type
  point
  (make-point x y)
  point?
  (x point.x point.x-set!)
  (y point.y point.y-set!))
#<unspecified>
(define p (make-point 1 2))
#<unspecified>
(point? p)
#t
(point.y p)
2
(point.y-set! p 7)
#<unspecified>
(point.y p)
7
(define-record-scheme <point #f <point? (x <point.x) (y <point.y))
#<unspecified>
(define-record-scheme <color #f <color? (hue <color.hue))
#<unspecified>
(define-record-type (point <point) make-point point? (x point.x) (y point.y))
#<unspecified>
(define-record-type (color <color) make-color)
#<unspecified>
(define-record-type
  (color-point <color <point)
  (make-color-point x y hue)
  color-point?
  (extra color-point.extra))
#<unspecified>
(define cp (make-color-point 1 2 'blue))
#<unspecified>
(<point? cp)
#t
(<color? cp)
#t
(color-point? cp)
#t
(<point.y cp)
2
(<color.hue cp)
blue
(color-point.extra cp)
<undefined>
(define p (point (x 1) (y 2)))
#<unspecified>
(define cp (color-point (hue 'blue) (x 1) (y 2)))
#<unspecified>
(show (record-update p point (x 7)))
[debug] Runtime error_________________________________

(exn bounds)

Error: (vector-ref) out of range
#((vector) internal-name 7 2)
4

Backtrace:

0: (vector-ref #((vector) internal-name 7 2) 4)
1: (2894075111735847$$generated-identifier #((vector) internal-name 7 2))
   ((lambda (g3106) ...) g3106)
2: (g3104 #((vector) internal-name 7 2))
   ((lambda (g3105) ...) g3105)
3: (g1691 #((vector) internal-name 7 2))
   ((lambda (g1694) ...) g1694)
4: (##sys#apply #<procedure> (#((vector) internal-name 7 2)))
   ((lambda (g1693) ...) g1693)
5: ((lambda (g1693) (if (eq? g1693 (length (quote (x)))) (##sys#apply (lambda (g1694) (g1691 g1694)) g1692) (if (eq? 
g1693...
...


Effectively, all records share the same tag ("internal-name").

Now, is my implementation of srfi-9:define-record-type broken?
Or how should a non-generative version of it be defined?
Or am I just misunderstanding things completely?


cheers,
felix