;*=====================================================================*/
;*    serrano/prgm/project/bigloo/runtime/Eval/expd-record.scm         */
;*    -------------------------------------------------------------    */
;*    Author      :  Sven Hartrumpf                                    */
;*    Creation    :  Thu Mar 30 08:02:33 2000                          */
;*    Last change :  Mon May  7 18:46:51 2001 (serrano)                */
;*    -------------------------------------------------------------    */
;*    SRFI-9 Record expansion.                                         */
;*    -------------------------------------------------------------    */
;*    Source documentation:                                            */
;*       @path ../../manuals/struct.texi@                              */
;*       @node Records (SRFI-9)@                                       */
;*=====================================================================*/

;*---------------------------------------------------------------------*/
;*    The module                                                       */
;*---------------------------------------------------------------------*/
(module __expander_record
   
   (import  __error
	    __bigloo
	    __tvector
	    __structure
	    __tvector
	    __bexit
	    
	    __match_normalize
	     
	    __r4_numbers_6_5
	    __r4_numbers_6_5_fixnum
	    __r4_numbers_6_5_flonum
	    __r4_characters_6_6
	    __r4_equivalence_6_2
	    __r4_booleans_6_1
	    __r4_symbols_6_4
	    __r4_strings_6_7
	    __r4_pairs_and_lists_6_3
	    __r4_input_6_10_2
	    __r4_control_features_6_9
	    __r4_vectors_6_8
	    __r4_ports_6_10_1
	    __r4_output_6_10_3
	    
	    __progn)
   
   (use     __type
	    __evenv)
   
   (export  (expand-define-record-type x e)))

;*---------------------------------------------------------------------*/
;*    expand-define-record-type ...                                    */
;*---------------------------------------------------------------------*/
(define (expand-define-record-type x e)
   (if (not (symbol? *record-bigloo-stamp*))
       (set! *record-bigloo-stamp* (gensym 'record)))
   (define (err)
      (error "define-record-type" "Illegal `define-record-type' form" x))
   (match-case x
      ((?- (and (? symbol?) ?type)
	   (and (? pair?) ?constructor)
	   (and (? symbol?) ?predicate) . ?field-specs)
       (e
	(cons
	 'begin
	 (cons
	  (append `(define-struct ,(symbol-append type *record-bigloo-stamp*))
		  (map car field-specs))
	  (cons
	   ;; constructor
	   `(define ,constructor
	       ,(cons
		 'let
		 (append `(((record (,(symbol-append 'make- type
						     *record-bigloo-stamp*)))))
			 (map
			  (lambda (field)
			     (if (not (symbol? field))
				 (err)
				 `(,(symbol-append type *record-bigloo-stamp*
						   '- field '-set!)
				   record ,field)))
			  (cdr constructor))
			 '(record))))
	   (cons
	    ;; type test
	    (let ((standard-predicate (symbol-append type
						     *record-bigloo-stamp*
						     '?)))
	       `(define ,predicate ,standard-predicate))
	    (append
	     ;; accessors
	     (map (lambda (field-spec)
		     (if (or (not (pair? field-spec))
			     (not (symbol? (car field-spec))))
			 (err)
			 (let ((standard-accessor (symbol-append
						   type *record-bigloo-stamp*
						   '- (car field-spec))))
			    `(define ,(cadr field-spec) ,standard-accessor))))
		  field-specs)
	     ;; mutators
	     (map (lambda (field-spec)
		     (if (or (not (pair? field-spec))
			     (not (symbol? (car field-spec))))
			 (err)
			 (if (pair? (cddr field-spec))
			     (let ((standard-mutator (symbol-append
						      type
						      *record-bigloo-stamp*
						      '- (car field-spec)
						      '-set!)))
				`(define ,(caddr field-spec)
				    ,standard-mutator))
			     #t)))
		  field-specs))))))
	e))
      (else
       (err))))

;*---------------------------------------------------------------------*/
;*    *record-bigloo-stamp* ...                                        */
;*---------------------------------------------------------------------*/
(define *record-bigloo-stamp* *record-bigloo-stamp*)
