Asks for the name of the record and the fields and generates the record definition according to this common style:

  (define-record-name RECNAME :RECNAME 
    (make-RECNAME FIELD1 ...)
    RECNAME?
    (FIELD1 RECNAME-FIELD1 set-RECNAME-FIELD1)
     ...)

The generation of the mutator procedures is controlled by the users choice. The user can further choose interactively to generate a SRFI-9 record definition.

Send your comments and enhancements to EricKnauel and MartinGasbichler.

  (defun insert-record-definition (rec-name)
    "Insert a Scheme 48 or SRFI-9 style record definition"
    (interactive "sRecord name: ")

    (let* ((generate-srfi-9p (y-or-n-p "Generate SRFI-9 definition? "))
           (field-names (read-field-names))
           (field-names-and-setP (read-setP field-names)))
      (save-excursion
        (insert-string
         (build-define-record
          rec-name field-names-and-setP (not (null generate-srfi-9p)))))))

  (defun read-field-names ()
    ""
    (let ((field (read-string "Field: ")))
      (if (string= field "")
          '()
          (cons field (read-field-names)))))

  (defun read-setP (field-names)
    ""
    (message "Generate set! [(a)ll,(n)one,(i)nteractive]: ")
    (let ((answer (read-char)))
      (cond
       ((eq answer ?a)
        (mapcar (lambda (field-name) (cons field-name t)) field-names))
       ((eq answer ?n)
        (mapcar (lambda (field-name) (cons field-name nil)) field-names))
       ((eq answer ?i)
        (mapcar 'read-setP-for-field field-names))
       (t
        (read-setP field-names)))))

  (defun read-setP-for-field (field-name)
    ""
    (message "Generate set! for field %s? [(y)es,(n)o]" field-name)
    (let ((answer (read-char)))
      (cond
       ((eq answer ?y)
        (cons field-name t))
       ((eq answer ?n)
        (cons field-name nil))
       (t
        (read-setP-for-field field-name)))))


  (defun make-constructor-name (rec-name)
    ""
    (concat "make-" rec-name))

  (defun make-predicate-name (rec-name)
    ""
    (concat rec-name "?"))

  (defun make-accessor (field-name rec-name)
    ""
    (concat rec-name "-" field-name))

  (defun make-mutator (field-name rec-name)
    ""
    (concat "set-" rec-name "-" field-name "!"))

  (defun make-type-name (rec-name)
    ""
    (concat ":" rec-name))

  (defun build-define-record (rec-name field-names generate-srfi-9p)
    ""
    (concat
     "(define-record-type " rec-name " " (if generate-srfi-9p
                                             ""
                                           (make-type-name rec-name)) "\n"
     "(" (make-constructor-name rec-name)  (apply 'concat
                                                  (mapcar (lambda (field-name-and-setP)
                                                            (concat " " (car field-name-and-setP)))
                                                      field-names)) ")\n"
      (make-predicate-name rec-name)
      (apply 'concat
             (mapcar (lambda (field-name-and-setP)
                       (concat
                        "\n(" (car field-name-and-setP) " "
                        (make-accessor (car field-name-and-setP) rec-name)
                        (if (null (cdr field-name-and-setP))
                            ""
                          (concat " " (make-mutator (car field-name-and-setP) rec-name)))
                        ")"))
                     field-names))
     ")\n"))