;; generate SRFI-35 condition definitions
(defun read-field-names ()
""
(let ((field (read-string "Field: ")))
(if (string= field "")
'()
(cons field (read-field-names)))))
(defun prepend-ampersand (str)
(cond
((= (length str) 0) str)
((char-equal ?& (aref str 0)) str)
(t (concat "&" str))))
(defun strip-ampersand (str)
(cond
((= (length str) 0) str)
((char-equal ?& (aref str 0))
(apply 'string (cdr (string-to-list str))))
(t str)))
(defun make-condition-field-accessor-name (condition field)
(concat condition "-" field))
(defun build-define-condition-type (name parent fields)
(concat
"(define-condition-type "
(prepend-ampersand name) " " (prepend-ampersand parent) "\n"
(strip-ampersand name) "?"
(apply 'concat
(mapcar
(lambda (field)
(concat
"\n(" field " "
(make-condition-field-accessor-name (strip-ampersand name) field) ")"))
fields))
")\n"))
(defun insert-condition-definition (name)
"Insert a Scheme code for a SRFI-35 condition definition"
(interactive "sCondition name: ")
(let* ((parent (read-string "Parent: ")))
(let ((parent (if (string= parent "") nil parent))
(fields (read-field-names)))
(save-excursion
(insert-string
(build-define-condition-type name parent fields))))))
