;;;;
;;;; srfi-9.stk	-- SRFI-9 (Records)
;;;;
;;;; Copyright © 1999-2007 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
;;;;
;;;;
;;;; Permission to use, copy, modify, distribute,and license this
;;;; software and its documentation for any purpose is hereby granted,
;;;; provided that existing copyright notices are retained in all
;;;; copies and that this notice is included verbatim in any
;;;; distributions.  No written agreement, license, or royalty fee is
;;;; required for any of the authorized uses.
;;;; This software is provided ``AS IS'' without express or implied
;;;; warranty.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 27-Sep-1999 13:06 (eg)
;;;; Last file update:  4-May-2007 19:38 (eg)
;;;;


(define-macro (define-record-type name constructor predicate . fields)
  (let ((struct-type (gensym))
	(tmp 	     (gensym))
	(val	     (gensym)))
    `(begin
       ;; Define the constructor, the predicates and the accessors as global
       (define ,(car constructor) #f)
       (define ,predicate #f)
       ,@(map (lambda (x)
		(case (length x)
		  ((2) `(define ,(cadr x) #f))
		  ((3) `(begin
			  (define  ,(cadr x) #f)
			  (define ,(caddr x) #f)))
		  (else (error 'define-record-type
			       "bad field specification ~S" x))))
	      fields)
       ;;
       ;; Build the record using STklos structs
       ;;
       (let ((,struct-type (make-struct-type ',name #f ',(map car fields))))
	 ;; Make the constructor
	 (set! ,(car constructor)
	   (lambda ,(cdr constructor)
	     (let ((,tmp (make-struct ,struct-type)))
	       ,@(map (lambda (x) `(struct-set! ,tmp ',x ,x))
		      (cdr constructor))
	       ,tmp)))

	 ;; Make the predicate
	 (set! ,predicate
	   (lambda (,tmp) (and (struct? ,tmp) (struct-is-a? ,tmp ,struct-type))))

	 ;; Make the accessors
	 ,@(map (lambda (x)
		  (if (= (length x) 2)
		      `(set! ,(cadr x) (lambda (,tmp)
					 (struct-ref ,tmp ',(car x))))
		      ;; length = 3 (otherwise error was detected before)
		      `(begin
			 (set! ,(cadr x) (lambda (,tmp)
					   (struct-ref ,tmp ',(car x))))
			 (set! ,(caddr x) (lambda (,tmp ,val)
					    (struct-set! ,tmp ',(car x) ,val))))))
		fields)
	 ; Result for oplevel (if any)
	 (values (void) ',name)))))

(export-syntax define-record-type)
(provide "srfi-9")

#|
  Example of usage

	(define-record-type my-pair
	  (kons x y)
	  my-pair?
	  (x kar set-kar!)
	  (y kdr))

	(list
	   (my-pair? (kons 1 2))		; => #t
	   (my-pair? (cons 1 2))		; => #f
	   (kar (kons 1 2))			; => 1
	   (kdr (kons 1 2))			; => 2
	   (let ((k (kons 1 2)))
	     (set-kar! k 3)
	     (kar k)))				; => 3
|#