;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                                         ;;;
;;;  These macros implement records for MacScheme and PC Scheme             ;;;
;;;                                                                         ;;;
;;;                    Jeff Alexander and ShinnDer Li                       ;;;
;;;                                                                         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define error/define-record-or-variant-case
  (lambda args
    (for-each (lambda (x) (display x) (display " ")) args)
    (newline)
    (error "Error from define-record or variant-case.")))

(define list?      ; In MacScheme, this definition can be deleted.
  (lambda (item)
    (cond
      ((null? item) #t)
      (else (and (pair? item) (list? (cdr item)))))))

(define every?     ; In MacScheme, this definition can be deleted.
  (lambda (pred ls)
    (if (null? ls)
        #t
        (and (pred (car ls)) (every? pred (cdr ls))))))

(define all-true? every?) 

(define null-ended-list? list?)

(macro define-record
  (lambda (args)
    (if (and (null-ended-list? args)
             (= (length args) 3)
             (symbol? (cadr args))
             (null-ended-list? (caddr args))
             (all-true? symbol? (caddr args)))
        (let* ((vec-sym (gensym))
               (name (symbol->string (cadr args)))
               (name? (string->symbol (string-append name "?"))))
          (letrec
            ((loop
               (lambda (fields i)
                 (cond ((null? fields) '())
                       ((member (car fields) (cdr fields))
                        (error/define-record-or-variant-case
                          "define-record syntax error:"
                          (string-append name ",")
                          "duplicate field:"
                          (car fields))) 
                       (#t
                         (let ((accessor
                                 (string-append
                                   name
                                   "->"
                                   (symbol->string (car fields)))))
                           (cons
                             `(define ,(string->symbol accessor)
                                (lambda (obj)
                                  (if (,name? obj)
                                      (vector-ref obj ,i)
                                      (error/define-record-or-variant-case
                                        accessor ": bad record" obj))))
                             (loop (cdr fields) (add1 i)))))))))
            `(begin
               ,@(loop (caddr args) 1)
               (define ,name?
                 (lambda (obj)
                   (and (vector? obj)
                        (= (vector-length obj) ,(+ 1 (length (caddr args))))
                        (eq? (vector-ref obj 0) ',(cadr args)))))
               (define ,(string->symbol
                          (string-append (symbol->string 'make-) name))
                 (let ((,vec-sym vector))
                   (lambda ,(caddr args)
                     (,vec-sym ',(cadr args) ,@(caddr args))))))))
        (error/define-record-or-variant-case
          "define-record syntax error:" args))))

(macro variant-case
  (lambda (args)
    (let ((var (gensym)))
      (letrec
        ((loop
          (lambda (clause)
            (cond
             ((null? clause)
              `((#t (error/define-record-or-variant-case
                      "no clause matches:" ,var))))
             ((eq? (caar clause) 'else)
              (if (not (null? (cdr clause)))
                  (error/define-record-or-variant-case
                    "variant-case syntax error: clauses after an else."
                    (cdr clause))
                  `((#t ,@(cdar clause)))))
             ((assoc (caar clause) (cdr clause))
              (error/define-record-or-variant-case
                "variant-case syntax error: duplicate clause:"
                (caar clause)))
             (else
              (let ((name (symbol->string (caar clause))))
                (cons
                 `((,(string->symbol (string-append name "?")) ,var)
                   (let ,(let-vars name (cadar clause))
                     ,@(cddar clause)))
                 (loop (cdr clause))))))))
         (let-vars
           (lambda (name fields)
             (cond
              ((null? fields) '())
              ((member (car fields) (cdr fields))
               (error/define-record-or-variant-case
                 "variant-case syntax error: duplicate field. record:"
                 (string-append name "," " field:") (car fields)))
              (#t
               (cons
                `(,(car fields)
                  (,(string->symbol
                     (string-append
                      name "->" (symbol->string (car fields))))
                   ,var))
                (let-vars name (cdr fields))))))))
        (if (and (null-ended-list? args)
                 (> (length args) 2)
                 (all-true?
                  (lambda (clause)
                    (and (null-ended-list? clause)
                         (not (null? clause))
                         (symbol? (car clause))
                         (if (eq? (car clause) 'else)
                             (not (null? (cdr clause)))
                             (and (> (length clause) 2)
                                  (null-ended-list? (cadr clause))
                                  (all-true? symbol? (cadr clause))))))
                  (cddr args)))
            `(let ((,var ,(cadr args)))
                  (cond ,@(loop (cddr args))))
            (error/define-record-or-variant-case
              "variant-case syntax error:" args))))))