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