[Chicken-janitors] #1355: make define-record-type setters hygienic

[Chicken Trac]

#1355: make define-record-type setters hygienic
-----------------------------------------+--------------------------------
 Reporter:  ashinn                       |                 Owner:
     Type:  defect                       |                Status:  new
 Priority:  major                        |             Milestone:  someday
Component:  core libraries               |               Version:  4.12.0
 Keywords:  define-record-type, hygiene  |  Estimated difficulty:
-----------------------------------------+--------------------------------
 The following program with tests passes in chibi and scheme48, but fails
 in chicken.  The expander handles inserted "tmp" identifiers and
 disambiguates correctly for readers and predicates, but it appears define-
 record-type treats all the setters the same.

 {{{
 (cond-expand
  (chibi (import (scheme base) (chibi test)))
  (chicken (use test)))

 ;; other (,open srfi-9 srfi-23 in scheme48)
 ;; (define (read-string k in)
 ;;   (let lp ((i k) (res '()))
 ;;     (if (zero? i)
 ;;         (list->string (reverse res))
 ;;         (lp (- i 1) (cons (read-char in) res)))))
 ;; (define (test-begin) #f) (define (test-end) #f)
 ;; (define (test e x)
 ;;   (if (not (equal? e x))
 ;;       (error "test failed" e '!= x)))

 ;; utility primitive type consisting of a predicate, reader and writer

 (define-syntax define-binary-type
   (syntax-rules ()
     ((define-binary-type name pred reader writer)
      (define-syntax name
        (syntax-rules (pred: read: write:)
          ((name pred: args) (pred args))
          ((name read: args) (reader args))
          ((name write: args) (writer args)))))))

 ;; a fixed-length string

 (define-binary-type fixed-string
   (lambda (args)
     (let ((len (car args)))
       (lambda (x) (and (string? x) (= (string-length x) len)))))
   (lambda (args)
     (let ((len (car args)))
       (lambda (in)
         (read-string len in))))
   (lambda (args)
     (lambda (str out)
       (write-string str out))))

 ;; wrapper around define-record-type to provide type checking and
 ;; (de)serialization

 (define-syntax defrec
   (syntax-rules ()
     ;; all fields processed: expand record, reader and setters
     ((defrec name (make . make-fields) pred reader ()
        (field (type . args) read-field get %set set) ...)
      (begin
        (define-record-type name (make . make-fields) pred
          (field get %set) ...)
        (define set
          (let ((field? (type pred: 'args)))
            (lambda (x val)
              (if (not (field? val))
                  (error "invalid field" '(type . args) val))
              (%set x val))))
        ...
        (define reader
          (let ((read-field (type read: 'args)) ...)
            (lambda (in)
              (let ((field (read-field in)) ...)
                (make . make-fields)))))))
     ;; step: insert read-field and %set bindings
     ((defrec name make pred reader
        ((field (type . args) get set) . rest)
        fields ...)
      (defrec name make pred reader rest fields ...
        (field (type . args) read-field get %set set)))))

 (define-syntax define-binary-record-type
   (syntax-rules ()
     ((define-binary-record-type name make pred reader . fields)
      (defrec name make pred reader fields))))

 ;; example

 (define-binary-record-type stuff (make-stuff foo bar) stuff?
   read-stuff
   (foo (fixed-string 2) stuff-foo stuff-foo-set!)
   (bar (fixed-string 3) stuff-bar stuff-bar-set!))

 (test-begin)
 (let ((x (make-stuff "ab" "bar")))
   (test "ab" (stuff-foo x))
   (test "bar" (stuff-bar x))
   (stuff-foo-set! x "xy")    ;; <----- this checks the right field type
                              ;;        but uses the sets the wrong %set
   (test "xy" (stuff-foo x))
   (test "bar" (stuff-bar x)))
 (test-end)
 }}}

--
Ticket URL: <https://bugs.call-cc.org/ticket/1355>
CHICKEN Scheme <https://www.call-cc.org/>
CHICKEN Scheme is a compiler for the Scheme programming language.