;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                         ;;;
;;;      These macros implement records for PC Scheme Version 3.03          ;;;
;;;                                                                         ;;;
;;;        Jeff Alexander, Shinnder Lee, and Lewis Patterson                ;;;
;;;                                                                         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Some of the procedures are integrable, such as proc?. Since we want to
;;; redefine them, we must use define-integrable.

(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-integrable ,(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) (+ i 1)))))))
	    `(begin
	       ,@(make-fields field-accessors 1)
	       (define-integrable ,name?
		 (lambda (obj)
		   (and (vector? obj)
			(= (vector-length obj) ,(+ 1 (length field-accessors)))
			(eq? (vector-ref obj 0) ',name))))
	       (define-integrable ,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
  (let ((string->symbol
	  (lambda (s)
	    (implode (map char-upcase (string->list s))))))
    (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 ((string->symbol
	  (lambda (s)
	    (implode (map char-upcase (string->list s))))))
    (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)
    (error "displaylnerror")))