(herald defstruct)                                           ; -*- T -*-

;;;;;; Improved structure type definition macros

;;; Taylor Campbell wrote this code; he places it in the public domain.

;;; (DEFINE-STRUCTURE-TYPE* name
;;;   conser-spec
;;;   (other-field-spec ...)
;;;   (method-clause ...))
;;; conser-spec      ---> (conser-name conser-field-tag ...)
;;; other-field-spec ---> field-tag | (field-tag init)
;;;
;;; Example:
;;;
;;;   (DEFINE-STRUCTURE-TYPE SHIP
;;;     (MAKE-SHIP X Y)
;;;     ((CARGO '()))
;;;     (((PRINT SELF PORT)
;;;       (FORMAT PORT "#{Ship~_~S~_at (~S, ~S)~_with ~S}"
;;;               (OBJECT-HASH SELF)
;;;               (SHIP-X SELF)
;;;               (SHIP-Y SELF)
;;;               (SHIP-CARGO SELF)))))
;;;
;;;   (DEFINE S (MAKE-SHIP 5 3))
;;;   S                            ==> #{Ship 4 at (5, 3) with ()}
;;;   (SHIP-CARGO S)               ==> ()
;;;   (PUSH (SHIP-CARGO S) 'FOOD)  ==> (FOOD)
;;;   S                            ==> #{Ship 4 at (5, 3) with (FOOD)}
;;;   (SET (SHIP-X S) 10)          ==> 10
;;;   S                            ==> #{Ship 4 at (10, 3) with (FOOD)}

(import t-implementation-env valid-method-form?)

(define-safe-syntax (define-structure-type* type-name
                      conser-spec
                      . more)
                    (symbol?
                     (+ symbol?)
                     ;; Yuck.  The pattern predicate stuff ought to
                     ;; have a better way to write this.
                     . (| null?
                          ((+ (| symbol? (symbol? #f)))
                           . (| null?
                                ((+ valid-method-form?))))))
  (let ((stype-id (concatenate-symbol 'STYPE/ type-name)))
    (receive (conser-args field-tags init-specs master-init-specs)
             (extract-field-specs conser-spec more)
      `(BLOCK
         (DEFINE ,stype-id
                 (MAKE-STYPE ',type-name ',field-tags
                             ,(if (pair? (cdr more))
                                  `(OBJECT NIL ,@(cadr more))
                                  'NIL)))
         ,(generate-conser type-name stype-id
                           (car conser-spec) conser-args
                           init-specs)
         ,(generate-predicator type-name stype-id)
         ,@(generate-accessors type-name stype-id field-tags)
         ,@(if (null? master-init-specs)
               '()
               (list (generate-master-inits type-name stype-id
                                            master-init-specs)))))))

(declare local
  extract-field-specs
  generate-conser
  generate-field-set
  generate-predicator
  generate-accessors
  generate-master-inits)

(define (extract-field-specs conser-spec more)
  (receive (uninit-specs init-specs)
           (partition atom? (car more))
    (receive (master-init-specs conser-init-specs)
             (partition (lambda (spec)
                          (and (or (atom? (cadr spec))
                                   ;; Heuristic.
                                   (eq? (caadr spec) 'QUOTE))
                               (not (memq (cdr spec)
                                          (cdr conser-spec)))))
                        init-specs)
      (return (cdr conser-spec)
              (append (cdr conser-spec)
                      (map car init-specs)
                      uninit-specs)
              conser-init-specs
              master-init-specs))))

(define (partition pred list)
  (iterate loop ((list list) (left '()) (right '()))
    (cond ((null? list)
           (return (reverse! left) (reverse! right)))
          ((pred (car list))
           (loop (cdr list)
                 (cons (car list) left)
                 right))
          (else
           (loop (cdr list)
                 left
                 (cons (car list) right))))))

(define (generate-conser type-name stype-id
                         conser-id conser-args
                         init-specs)
  `(DEFINE ,conser-id
     ,(if (and (null? conser-args)
               (null? init-specs))
          `(STYPE-CONSTRUCTOR ,stype-id)
          (let ((%conser (generate-symbol
                          (concatenate-symbol '%CONS- type-name)))
                (%struct (generate-symbol type-name)))
            `(LET ((,%conser (STYPE-CONSTRUCTOR ,stype-id)))
               (LAMBDA ,conser-args
                 (LET ((,%struct (,%conser)))
                   ,@(map (lambda (arg)
                            (generate-field-set type-name arg %struct
                                                arg))
                          conser-args)
                   ,@(map (lambda (init-spec)
                            (generate-field-set type-name
                                                (car init-spec)
                                                %struct
                                                (cadr init-spec)))
                          init-specs)
                   ,%struct)))))))

(define (generate-field-set type-name field-tag struct exp)
  `(SET (,(concatenate-symbol type-name '- field-tag) ,struct)
        ,exp))

(define (generate-predicator type-name stype-id)
  `(DEFINE ,(concatenate-symbol type-name '?)
           (STYPE-PREDICATOR ,stype-id)))

(define (generate-accessors type-name stype-id field-tags)
  (do ((tags field-tags (cdr tags))
       (i 2 (fx+ i 4))
       (defs '()
             (cons `(DEFINE-CONSTANT ,(concatenate-symbol type-name
                                                          '-
                                                          (car tags))
                      (MAKE-STRUCTURE-ACCESSOR ,stype-id ,i
                                               ',(car tags)))
                   defs)))
      ((null? tags)
       (reverse! defs))))

(define (generate-master-inits type-name stype-id init-specs)
  (let ((%master (generate-symbol
                  (concatenate-symbol 'MASTER- type-name))))
    `(LET ((,%master (STYPE-MASTER ,stype-id)))
       ,@(map (lambda (init-spec)
                (generate-field-set type-name (car init-spec)
                                    %master
                                    (cadr init-spec)))
              init-specs))))