;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                         ;;;
;;;         These macros implement records for MacScheme                    ;;;
;;;                                                                         ;;;
;;;                Jeff Alexander & Shinnder Lee                            ;;;
;;;                                                                         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define string->symbol
  (let ((old-string->symbol string->symbol))
    (lambda (s)
      (old-string->symbol
	(list->string (map char-downcase (string->list s)))))))

(macro define-record
  (let* ((vec-sym (gensym)))
    (lambda (args)
      (check-define-record-syntax args
	(lambda (name make-name name? field-accessors)
	  (letrec
	    ((make-fields
	       (lambda (field-accessors i)
		 (if (null? field-accessors)
		     '()
		     (cons
		       `(define ,(car field-accessors)
			  (lambda (obj)
			    (if (,name? obj)
				(vector-ref obj ,i)
				(displayln-error ',(car field-accessors)
				  ": bad record" obj))))
		       (make-fields (cdr field-accessors) (add1 i)))))))
	    `(begin
	       ,@(make-fields field-accessors 1)
	       (define ,name?
		 (lambda (obj)
		   (and (vector? obj)
			(= (vector-length obj) ,(+ 1 (length field-accessors)))
			(eq? (vector-ref obj 0) ',name))))
	       (define ,make-name
		 (let ((,vec-sym vector))
		   (lambda ,field-accessors
		     (,vec-sym ',name ,@field-accessors)))))))))))

(macro variant-case
  (lambda (args)
    (check-variant-case-syntax args
      (lambda (exp clauses)
	(let ((var (gensym)))
	  (let
	    ((make-clause
	       (lambda (clause)
		 (if (eq? (car clause) 'else)
		     `(#t ,@(cdr clause))
		     `((,(car clause) ,var)
		       (let ,(map (lambda (field)
				    `(,(car field) (,(cdr field) ,var)))
				  (cadr clause))
			 ,@(cddr clause)))))))
	    `(let ((,var ,exp))
	       (cond ,@(map make-clause clauses)))))))))

;;; syntax checkers

;;; name make-name name? field-accessors

(define check-define-record-syntax
  (lambda (x k)
    (cond
      ((and (list? x)
	    (= (length x) 3)
	    (symbol? (cadr x))
	    (list? (caddr x))
	    (andmap symbol? (caddr x))
	    (not (duplicate-fields? (caddr x))))
       (let ((name (symbol->string (cadr x))))
	 (let ((make-name (string->symbol (string-append 
					    (symbol->string 'make-) name)))
	       (name? (string->symbol (string-append name "?")))
	       (field-accessors
		 (map
		   (lambda (field)
		     (string->symbol
		       (string-append name "->" (symbol->string field))))
		   (caddr x))))
	   (k (cadr x) make-name name? field-accessors))))
      (else (displayln-error "define-record: invalid syntax" x)))))
       
(define check-variant-case-syntax
  (let
    ((make-clause
       (lambda (clause)
	 (if (eq? (car clause) 'else) 
	     clause
	     (let ((name (symbol->string (car clause))))
	       (let ((name? (string->symbol (string-append name "?")))
		     (fields
		       (map
			 (lambda (field)
			   (cons field
		             (string->symbol
			       (string-append name "->"
				 (symbol->string field)))))
			 (cadr clause))))
		 (cons name? (cons fields (cddr clause)))))))))
    (lambda (args k)
      (if (and (list? args)
	       (<= 3 (length args))
	       (clauses? (cddr args)))
	  (k (cadr args) (map make-clause (cddr args)))
	  (displayln-error "variant-case: invalid syntax" args)))))

(define duplicate-fields?
  (lambda (fields)
    (cond
      ((null? fields) #f)
      ((memq (car fields) (cdr fields)) #t)
      (else (duplicate-fields? (cdr fields))))))

(define clauses?
  (let
    ((clause?
       (lambda (clause)
	 (and (list? clause)
	      (not (null? clause))
	      (cond
		((eq? (car clause) 'else)
		 (not (null? (cdr clause))))
		(else (and (symbol? (car clause))
			   (not (null? (cdr clause)))
			   (list? (cadr clause))
			   (andmap symbol? (cadr clause))
			   (not (duplicate-fields? (cadr clause)))
			   (not (null? (cddr clause))))))))))
    (letrec
      ((duplicate-tags?
	 (lambda (tags)
	   (cond
	     ((null? tags) #f)
	     ((eq? (car tags) 'else) (not (null? (cdr tags))))
	     ((memq (car tags) (cdr tags)) #t)
	     (else (duplicate-tags? (cdr tags)))))))
      (lambda (clauses)
	(and (andmap clause? clauses)
	     (not (duplicate-tags? (map car clauses))))))))

(define list?
  (lambda (item)
    (cond
      ((null? item) #t)
      (else (and (pair? item) (list? (cdr item)))))))

(define andmap
  (lambda (pred ls)
    (if (null? ls)
	#t
	(and (pred (car ls)) (andmap pred (cdr ls))))))

(define displayln-error
  (lambda args
    (for-each (lambda (x) (display x) (display " ")) args)
    (newline)
    (reset)))