;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; ERR5RS Records.
; Reference implementation.
;
; Copyright (C) William D Clinger 2008. All Rights Reserved.
; 
; Permission is hereby granted, free of charge, to any person
; obtaining a copy of this software and associated documentation
; files (the "Software"), to deal in the Software without
; restriction, including without limitation the rights to use,
; copy, modify, merge, publish, distribute, sublicense, and/or
; sell copies of the Software, and to permit persons to whom
; the Software is furnished to do so, subject to the following
; conditions:
; 
; The above copyright notice and this permission notice shall
; be included in all copies or substantial portions of the
; Software.
; 
; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY
; KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE
; WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR
; PURPOSE AND NONINFRINGEMENT. REMEMBER, THERE IS NO SCHEME
; UNDERGROUND. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE
; OR OTHER DEALINGS IN THE SOFTWARE.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; This is a quick-and-dirty reference implementation that favors
; simplicity over quality error messages and performance.  It is
; implemented using the R6RS procedural and inspection layers,
; with which it interoperates nicely.
;
; This file consists of four libraries followed by an R6RS
; top-level program.  In some implementations of the R6RS,
; this file can be executed as a top-level program.  In
; other implementations of the R6RS, it may be necessary to
; change the name of this file or to extract the libraries
; from this file using an implementation-dependent mechanism.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; This library breaks a circular interdependence between the
; procedural and inspection layers.

(library (srfi :99 records helpers)
  (export rtd?)
  (import (rnrs base) (rnrs records procedural))

  (define rtd? record-type-descriptor?)

  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; (srfi :99 records inspection)
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  
(library (srfi :99 records inspection)

  (export record? record-rtd
          rtd-name rtd-parent
          rtd-field-names rtd-all-field-names rtd-field-mutable?)

  (import (rnrs base)
          (rnrs lists)
          (rnrs records inspection)
          (srfi :99 records helpers))

  ; The record? predicate is already defined by (rnrs records inspection).
  
  ; The record-rtd procedure is already defined by (rnrs records inspection).
  
  (define rtd-name record-type-name)
  
  (define rtd-parent record-type-parent)
  
  (define rtd-field-names record-type-field-names)
  
  (define (rtd-all-field-names rtd)
    (define (loop rtd othernames)
      (let ((parent (rtd-parent rtd))
            (names (append (vector->list
                            (rtd-field-names rtd))
                           othernames)))
        (if parent
            (loop parent names)
            (list->vector names))))
    (loop rtd '()))
  
  (define (rtd-field-mutable? rtd0 fieldname)
    (define (loop rtd)
      (if (rtd? rtd)
          (let* ((names (vector->list (rtd-field-names rtd)))
                 (probe (memq fieldname names)))
            (if probe
                (record-field-mutable? rtd (- (length names) (length probe)))
                (loop (rtd-parent rtd))))
          (assertion-violation 'rtd-field-mutable?
                               "illegal argument" rtd0 fieldname)))
    (loop rtd0))

  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; (srfi :99 records procedural)
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(library (srfi :99 records procedural)

  (export make-rtd rtd? rtd-constructor
          rtd-predicate rtd-accessor rtd-mutator)

  (import (rnrs base)
          (rnrs lists)
          (rnrs records procedural)
          (srfi :99 records inspection))

  ; Note: the options are permitted by ERR5RS,
  ; but are not part of ERR5RS.

  (define (make-rtd name fieldspecs . rest)
    (let* ((parent (if (null? rest) #f (car rest)))
           (options (if (null? rest) '() (cdr rest)))
           (sealed? (and (memq 'sealed options) #t))
           (opaque? (and (memq 'opaque options) #t))
           (uid (let ((probe (memq 'uid options)))
                  (if (and probe (not (null? (cdr probe))))
                      (cadr probe)
                      #f))))
      (make-record-type-descriptor
       name
       parent
       uid
       sealed?
       opaque?
       (vector-map (lambda (fieldspec)
                     (if (symbol? fieldspec)
                         (list 'mutable fieldspec)
                         fieldspec))
                   fieldspecs))))
  
  (define rtd? record-type-descriptor?)
  
  (define (rtd-constructor rtd . rest)
  
    ; Computes permutation and allocates permutation buffer
    ; when the constructor is created, not when the constructor
    ; is called.  More error checking is recommended.
  
    (define (make-constructor fieldspecs allnames maker)
      (let* ((k (length fieldspecs))
             (n (length allnames))
             (buffer (make-vector n))
             (reverse-all-names (reverse allnames)))
  
        (define (position fieldname)
          (let ((names (memq fieldname reverse-all-names)))
            (assert names)
            (- (length names) 1)))
  
        (let ((indexes (map position fieldspecs)))
  
          ; The following can be made quite efficient by
          ; hand-coding it in some lower-level language,
          ; e.g. Larceny's mal.  Even case-lambda would
          ; be good enough in most systems.
  
          (lambda args
            (assert (= (length args) k))
            (for-each (lambda (arg posn)
                        (vector-set! buffer posn arg))
                      args indexes)
            (apply maker (vector->list buffer))))))
  
    (if (null? rest)
        (record-constructor
         (make-record-constructor-descriptor rtd #f #f))
        (begin (assert (null? (cdr rest)))
               (make-constructor
                (vector->list (car rest))
                (vector->list (rtd-all-field-names rtd))
                (record-constructor
                 (make-record-constructor-descriptor rtd #f #f))))))
  
  (define rtd-predicate record-predicate)
  
  (define (rtd-accessor rtd0 fieldname)
    (define (loop rtd)
      (if (rtd? rtd)
          (let* ((names (vector->list (rtd-field-names rtd)))
                 (probe (memq fieldname names)))
            (if probe
                (record-accessor rtd (- (length names) (length probe)))
                (loop (rtd-parent rtd))))
          (assertion-violation 'rtd-accessor
                               "illegal argument" rtd0 fieldname)))
    (loop rtd0))
  
  (define (rtd-mutator rtd0 fieldname)
    (define (loop rtd)
      (if (rtd? rtd)
          (let* ((names (vector->list (rtd-field-names rtd)))
                 (probe (memq fieldname names)))
            (if probe
                (record-mutator rtd (- (length names) (length probe)))
                (loop (rtd-parent rtd))))
          (assertion-violation 'rtd-mutator
                               "illegal argument" rtd0 fieldname)))
    (loop rtd0))

  )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; ERR5RS records, syntactic layer.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(library (srfi :99 records syntactic)

  (export define-record-type)

  (import (for (rnrs base) run expand)
          (for (rnrs lists) run expand)
          (for (rnrs syntax-case) run expand)
          (srfi :99 records procedural))

  (define-syntax define-record-type
    (syntax-rules ()
     ((_ (type-name parent) constructor-spec predicate-spec . field-specs)
      (define-record-type-helper0
       type-name parent constructor-spec predicate-spec . field-specs))
     ((_ type-name constructor-spec predicate-spec . field-specs)
      (define-record-type-helper0
       type-name #f constructor-spec predicate-spec . field-specs))))

  (define-syntax define-record-type-helper0
    (lambda (x)
      (define (complain)
        (syntax-violation 'define-record-type "illegal syntax" x))
      (syntax-case x ()
       ((_ tname pname constructor-spec predicate-spec . field-specs)
        (let* ((type-name (syntax->datum #'tname))
               (parent (syntax->datum #'pname))
               (cspec (syntax->datum #'constructor-spec))
               (pspec (syntax->datum #'predicate-spec))
               (fspecs (syntax->datum #'field-specs))
               (type-name-string
                (begin (if (not (symbol? type-name))
                           (complain))
                       (symbol->string type-name)))
               (constructor-name
                (cond ((eq? cspec #f)
                       #f)
                      ((eq? cspec #t)
                       (string->symbol
                        (string-append "make-" type-name-string)))
                      ((symbol? cspec)
                       cspec)
                      ((pair? cspec)
                       (car cspec))
                      (else (complain))))
               (constructor-args
                (cond ((pair? cspec)
                       (if (not (for-all symbol? cspec))
                           (complain)
                           (list->vector (cdr cspec))))
                      (else #f)))
               (predicate-name
                (cond ((eq? pspec #f)
                       #f)
                      ((eq? pspec #t)
                       (string->symbol
                        (string-append type-name-string "?")))
                      ((symbol? pspec)
                       pspec)
                      (else (complain))))
               (field-specs
                (map (lambda (fspec)
                       (cond ((symbol? fspec)
                              (list 'immutable
                                    fspec
                                    (string->symbol
                                     (string-append
                                      type-name-string
                                      "-"
                                      (symbol->string fspec)))))
                             ((not (pair? fspec))
                              (complain))
                             ((not (list? fspec))
                              (complain))
                             ((not (for-all symbol? fspec))
                              (complain))
                             ((null? (cdr fspec))
                              (list 'mutable
                                    (car fspec)
                                    (string->symbol
                                     (string-append
                                      type-name-string
                                      "-"
                                      (symbol->string (car fspec))))
                                    (string->symbol
                                     (string-append
                                      type-name-string
                                      "-"
                                      (symbol->string (car fspec))
                                      "-set!"))))
                             ((null? (cddr fspec))
                              (list 'immutable
                                    (car fspec)
                                    (cadr fspec)))
                             ((null? (cdddr fspec))
                              (cons 'mutable fspec))
                             (else (complain))))
                     fspecs))
  
               (fields (list->vector (map cadr field-specs)))
  
               (accessor-fields
                (map (lambda (x) (list (caddr x) (cadr x)))
                     (filter (lambda (x) (>= (length x) 3))
                             field-specs)))
  
               (mutator-fields
                (map (lambda (x) (list (cadddr x) (cadr x)))
                     (filter (lambda (x) (= (length x) 4))
                             field-specs))))
  
          (cons #'define-record-type-helper
                (datum->syntax
                 #'tname
                 `(,type-name ,fields ,parent
                   ,(if constructor-args
                        (list constructor-name constructor-args)
                        constructor-name)
                   ,predicate-name
                   ,accessor-fields ,mutator-fields))))))))
  
  (define-syntax define-record-type-helper
    (syntax-rules ()
  
     ((_ type-name fields parent #f predicate
         ((accessor field) ...) ((mutator mutable-field) ...))
      (define-record-type-helper
       type-name fields parent ignored predicate
       ((accessor field) ...) ((mutator mutable-field) ...)))
  
     ((_ type-name fields parent constructor #f
         ((accessor field) ...) ((mutator mutable-field) ...))
      (define-record-type-helper
       type-name fields parent constructor ignored
       ((accessor field) ...) ((mutator mutable-field) ...)))
  
     ((_ type-name fields parent (constructor args) predicate
         ((accessor field) ...) ((mutator mutable-field) ...))
      (begin (define type-name (make-rtd 'type-name 'fields parent))
             (define constructor (rtd-constructor type-name 'args))
             (define predicate (rtd-predicate type-name))
             (define accessor (rtd-accessor type-name 'field))
             ...
             (define mutator (rtd-mutator type-name 'mutable-field))
             ...))
  
     ((_ type-name fields parent constructor predicate
         ((accessor field) ...) ((mutator mutable-field) ...))
      (begin (define type-name (make-rtd 'type-name 'fields parent))
             (define constructor (rtd-constructor type-name))
             (define predicate (rtd-predicate type-name))
             (define accessor (rtd-accessor type-name 'field))
             ...
             (define mutator (rtd-mutator type-name 'mutable-field))
             ...))))

  ) ; srfi :99 records syntactic

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Top-level R6RS program containing the two examples from
; SRFI 99, with the second example repeated using the
; syntactic layer.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(import (rnrs base)
        (rnrs io simple)
        (srfi :99 records procedural)
        (srfi :99 records inspection)
        (srfi :99 records syntactic))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; For convenient display of records.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (record->vector r)
  (define (loop rtd othervalues)
    (let ((parent (rtd-parent rtd))
          (values (append (vector->list
                           (vector-map (lambda (fieldname)
                                         ((rtd-accessor rtd fieldname) r))
                                       (rtd-field-names rtd)))
                          othervalues)))
      (if parent
          (loop parent values)
          (list->vector values))))
  (loop (record-rtd r) '()))

(define (display-record r . rest)
  (let ((rtd (record-rtd r))
        (out (cond ((null? rest) (current-output-port))
                   ((null? (cdr rest)) (car rest))
                   (else (assert #f)))))
    (write (record->vector r) out)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; For convenient display of results.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (show x . rest)
  (let ((out (cond ((null? rest) (current-output-port))
                   ((null? (cdr rest)) (car rest))
                   (else (assert #f)))))
    (write x out)
    (newline out)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Example 1 from SRFI 99
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define rtd1
  (make-rtd 'rtd1 '#((immutable x1) (immutable x2))))

(define rtd2
  (make-rtd 'rtd2 '#((immutable x3) (immutable x4)) rtd1))

(define rtd3
  (make-rtd 'rtd3 '#((immutable x5) (immutable x6)) rtd2))

(define protocol1
  (lambda (p)
    (lambda (a b c)
      (p (+ a b) (+ b c)))))

(define protocol2
  (lambda (n)
    (lambda (a b c d e f)
      (let ((p (n a b c)))
        (p (+ d e) (+ e f))))))

(define protocol3
  (lambda (n)
    (lambda (a b c d e f g h i)
      (let ((p (n a b c d e f)))
        (p (+ g h) (+ h i))))))

(define make-rtd1
  (protocol1 (rtd-constructor rtd1)))

(define make-rtd2
  (let ((maker2 (rtd-constructor rtd2)))
    (protocol2
     (protocol1
      (lambda (x1 x2)
        (lambda (x3 x4)
          (maker2 x1 x2 x3 x4)))))))

(define make-rtd3
  (let ((maker3 (rtd-constructor rtd3)))
    (protocol3
     (protocol2
      (protocol1
       (lambda (x1 x2)
         (lambda (x3 x4)
           (lambda (x5 x6)
             (maker3 x1 x2 x3 x4 x5 x6)))))))))

(make-rtd3 1 2 3 4 5 6 7 8 9)

; evaluates to a record whose fields contain
; 3 5 9 11 15 17

(display-record (make-rtd3 1 2 3 4 5 6 7 8 9))
(newline)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Example 2 from SRFI 99
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

; The (let () ...) prevents these definitions from affecting
; the syntactic version of this example.

(let ()

(define :point
  (make-rtd 'point '#((mutable x) (mutable y))))

(define make-point (rtd-constructor :point))

(define point? (rtd-predicate :point))
(define point-x (rtd-accessor :point 'x))
(define point-y (rtd-accessor :point 'y))
(define point-x-set! (rtd-mutator :point 'x))
(define point-y-set! (rtd-mutator :point 'y))

(define p1 (make-point 1 2))

(define :point2
  (make-rtd 'point2 '#((mutable x) (mutable y)) :point))

(define make-point2
  (rtd-constructor :point2))
(define point2? (rtd-predicate :point2))
(define point2-xx (rtd-accessor :point2 'x))
(define point2-yy (rtd-accessor :point2 'y))

(define p2 (make-point2 1 2 3 4))

(define make-point/abs
  (let ((maker (rtd-constructor :point)))
    (lambda (x y)
      (maker (abs x) (abs y)))))

(define :cpoint
  (make-rtd 'cpoint '#((mutable rgb)) :point))

(define make-cpoint
  (let ((maker (rtd-constructor :cpoint)))
    (lambda (x y c)
      (maker x y (color->rgb c)))))

(define make-cpoint/abs
  (let ((maker (rtd-constructor :cpoint)))
    (lambda (x y c)
      (maker (abs x) (abs y) (color->rgb c)))))

(define cpoint-rgb
  (rtd-accessor :cpoint 'rgb))

(define (color->rgb c)
  (cons 'rgb c))

(show (point? p1))                             ; => #t
(show (point-x p1))                            ; => 1
(show (point-y p1))                            ; => 2
(point-x-set! p1 5)
(show (point-x p1))                            ; => 5

(show (point? p2))                             ; => #t
(show (point-x p2))                            ; => 1
(show (point-y p2))                            ; => 2
(show (point2-xx p2))                          ; => 3
(show (point2-yy p2))                          ; => 4

(show (point-x (make-point/abs -1 -2)))        ; => 1
(show (point-y (make-point/abs -1 -2)))        ; => 2

(show (cpoint-rgb (make-cpoint -1 -3 'red)))   ; => (rgb . red)
(show (point-x (make-cpoint -1 -3 'red)))      ; => -1
(show (point-x (make-cpoint/abs -1 -3 'red)))  ; => 1

; should print
; #(5 2)
; #(1 2 3 4)
; #(1 2)
; #(-1 -3 (rgb . red))

(display-record p1)
(newline)
(display-record p2)
(newline)
(display-record (make-point/abs -1 -2))
(newline)
(display-record (make-cpoint -1 -3 'red))
(newline)

)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Example 2 from SRFI 99, using the syntactic layer.
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(let ()

(define-record-type :point make-point point?
  (x point-x point-x-set!) (y point-y point-y-set!))

(define p1 (make-point 1 2))

(define-record-type (:point2 :point) make-point2 point2?
  (x point2-xx point2-xx-set!) (y point2-yy point2-yy-set!))

(define p2 (make-point2 1 2 3 4))

(define make-point/abs
  (let ((maker (rtd-constructor :point)))
    (lambda (x y)
      (maker (abs x) (abs y)))))

(define-record-type (:cpoint :point) #t #f
  (rgb cpoint-rgb cpoint-rgb-set!))

(define make-cpoint
  (lambda (x y c)
    (make-:cpoint x y (color->rgb c))))

(define make-cpoint/abs
  (lambda (x y c)
    (make-:cpoint (abs x) (abs y) (color->rgb c))))

(define (color->rgb c)
  (cons 'rgb c))

(show (point? p1))                             ; => #t
(show (point-x p1))                            ; => 1
(show (point-y p1))                            ; => 2
(point-x-set! p1 5)
(show (point-x p1))                            ; => 5

(show (point? p2))                             ; => #t
(show (point-x p2))                            ; => 1
(show (point-y p2))                            ; => 2
(show (point2-xx p2))                          ; => 3
(show (point2-yy p2))                          ; => 4

(show (point-x (make-point/abs -1 -2)))        ; => 1
(show (point-y (make-point/abs -1 -2)))        ; => 2

(show (cpoint-rgb (make-cpoint -1 -3 'red)))   ; => (rgb . red)
(show (point-x (make-cpoint -1 -3 'red)))      ; => -1
(show (point-x (make-cpoint/abs -1 -3 'red)))  ; => 1

; should print
; #(5 2)
; #(1 2 3 4)
; #(1 2)
; #(-1 -3 (rgb . red))

(display-record p1)
(newline)
(display-record p2)
(newline)
(display-record (make-point/abs -1 -2))
(newline)
(display-record (make-cpoint -1 -3 'red))
(newline)

)