;;; -*-Scheme-*-
;;;
;;; The Scheme part of the structures implementation
;;;
;;; (define-structure name slot slot ...)
;;;
;;; slot  =  slot-name  or  (slot-name initial-value)

(require 'structures 'struct.o)

(define-macro (define-structure name . slot-descr)
  (if (not (symbol? name))
      (error 'define-structure "structure name must be a symbol"))
  (if (null? slot-descr)
      (error 'define-structure "structure has no slots"))
  (let* ((s (symbol->string name))
	 (constructor
	  (string->symbol (string-append "make-" s)))
	 (predicator
	  (string->symbol (string-append s "?")))
	 (copier
	  (string->symbol (string-append "copy-" s)))
	 (slots '()) (arg-slots '()))
    (for-each
     (lambda (slot)
       (cond ((symbol? slot)
	      (set! slots (cons slot slots))
	      (set! arg-slots (cons slot arg-slots)))
	     ((pair? slot)
	      (if (or (not (pair? (cdr slot)))
		      (not (null? (cddr slot))))
		  (error 'define-structure "invalid slot specification")
		  (if (not (symbol? (car slot)))
		      (error 'define-structure "slot name must be a symbol"))
		  (set! slots (cons (car slot) slots))))
	     (else
	      (error 'define-structure "slot must be symbol or list"))))
     slot-descr)
    (set! slots (reverse slots))
    `(begin
       (make-constructor ,constructor ,name ,slots
			 ,(reverse arg-slots) ,slot-descr)
       (make-predicator ,predicator ',name)
       (make-copier ,copier)
       ,@(let ((offset -1))
	   (map
	    (lambda (slot)
		  (let ((f
			 (string->symbol (format #f "~s-~s" name slot))))
		    (set! offset (1+ offset))
		    `(make-accessor ,f ',name ,offset)))
	    slots))
       ,@(let ((offset -1))
	   (map
	    (lambda (slot)
	      (let ((f
		     (string->symbol (format #f "set-~s-~s!" name slot))))
		(set! offset (1+ offset))
		`(make-mutator ,f ',name ,offset)))
	    slots))
       ',name)))

(define-macro (make-constructor constructor name slots arg-slots descr)
  `(define (,constructor ,@arg-slots)
     (let ((,name (make-structure ',name ',slots)))
       ,@(let ((offset -1))
	   (map
	    (lambda (slot)
	      (set! offset (1+ offset))
	      `(structure-set! ,name ',name ,offset
			       ,(if (symbol? slot)
				    slot
				    (cadr slot))))
	    descr))
       ,name)))
       
(define-macro (make-predicator predicator name)
  `(define (,predicator x)
     (and (structure? x) (eq? (structure-name x) ,name))))

(define-macro (make-copier copier)
  `(define (,copier x)
     (copy-structure x)))

(define-macro (make-accessor accessor name offset)
  `(define (,accessor x)
     (structure-ref x ,name ,offset)))

(define-macro (make-mutator mutator name offset)
  `(define (,mutator x val)
     (structure-set! x ,name ,offset val)))

(define (copy-structure s)
  (let* ((slots (structure-slots s))
	 (name (structure-name s))
	 (new (make-structure name slots))
	 (size (length slots)))
    (do ((offset 0 (1+ offset))) ((= offset size) new)
      (structure-set! new name offset (structure-ref s name offset)))))

(define (describe-structure s)
  (format #t "a structure of type ~s.~%" (structure-name s))
  (if (null? (structure-slots s))
      (format #t "It has no slots.~%")
      (format #t "Its slots are: ")
      (let loop ((slots (structure-slots s))
		 (values (structure-values s)))
	(if (null? slots)
	    (format #t ".~%")
	    (format #t " (~s ~s)" (car slots) (car values))
	    (loop (cdr slots) (cdr values))))))
