(export
  define-record-type)
(import (only (csc builtins)
          call-builtin))
(begin


  ; There are a few builtin types such as vector, which uses type code 0. We'll
  ; start at 10 to give some room for more in the future.
  (define *next-type-id* 10)


  (define-syntax macro-length
    (syntax-rules ()
      ((macro-length ()) 0)
      ((macro-length (x xs ...))
        (+ 1 (macro-length (xs ...))))))


  (define-syntax set-arguments
    (syntax-rules ()
      ((set-arguments _ _)
        #f)
      ((set-arguments r n field1 field2 ...)
        (begin
          (call-builtin poke field1 r n)
          (set-arguments r (+ 1 n) field2 ...)))))


  (define-syntax define-selectors
    (syntax-rules ()
      ((define-selectors pred (selectors ...))
        (values selectors ...))
      ((define-selectors pred (selectors ...) (field getter) selector ...)
        (define-selectors pred (selectors ... (lambda (r)
                                                (unless (pred r)
                                                  (error "unexpected type in getter" r 'getter))
                                                (call-builtin peek r field)))
          selector ...))
      ((define-selectors pred (selectors ...) (field getter setter) selector ...)
        (define-selectors pred (selectors ... (lambda (r)
                                                (unless (pred r)
                                                  (error "unexpected type in getter" r 'getter))
                                                (call-builtin peek r field))
                                              (lambda (r val)
                                                (unless (pred r)
                                                  (error "unexpected type in setter" r 'setter))
                                                (call-builtin poke val r field)))
          selector ...))))


  (define-syntax enumerate-fields
    (syntax-rules ()
      ((enumerate-fields _ selectors)
        (define-selectors selectors))
      ((enumerate-fields n selectors field1 field2 ...)
        (begin
          (define field1 n)
          (enumerate-fields (+ 1 n) selectors field2 ...)))))


  (define-syntax selector-names
    (syntax-rules ()
      ((selector-names selectors (field ...) (name ...))
        (define-values (name ...)
          (enumerate-fields 1 selectors field ...)))
      ((selector-names selectors fields (names ...) (_ getter) selector ...)
        (selector-names selectors fields (names ... getter) selector ...))
      ((selector-names selectors fields (names ...) (_ getter setter) selector ...)
        (selector-names selectors fields (names ... getter setter) selector ...))))


  (define-syntax define-record-type
    (syntax-rules ()
      ((define-record-type _
         (constructor field ...)
         pred
         selectors ...)
        (define type-id
          (let ((id *next-type-id*))
            (set! *next-type-id* (call-builtin + 1 *next-type-id*))))
        (define (pred r)
          (call-builtin eq? type-id (call-builtin peek r 0)))
        (define (constructor field ...)
          (define r (call-builtin alloc (macro-length (field ...))))
          (call-builtin poke type-id r 0)
          (set-arguments r 1 field ...)
          r)
        (selector-names (selectors ...) (field ...) () selectors ...)))))