defstruct-parsing

(defun defstruct-conc-name
  (name options)
  (cond ((endp options) (string-append (symbol-name name)
        "-"))
    ((eq ':conc-name (car options)) "")
    ((and (consp (car options))
       (eq ':conc-name (caar options))) (let ((arglst (cdar options)))
        (if (and (consp arglst)
            (symbolp (car arglst))
            (car arglst))
          (symbol-name (car arglst))
          "")))
    (t (defstruct-conc-name name
        (cdr options)))))

(defun defstruct-constructor-name-lst1
  (name options
    sofar
    nilseen)
  (cond ((endp options) (cond (sofar sofar)
        (nilseen nil)
        (t (list (intern-in-package-of-symbol (string-append "MAKE-"
                (symbol-name name))
              name)))))
    ((and (consp (car options))
       (eq ':constructor (caar options))
       (consp (cdar options))) (cond ((null (cadar options)) (defstruct-constructor-name-lst1 name
            (cdr options)
            sofar
            t))
        ((symbolp (cadar options)) (defstruct-constructor-name-lst1 name
            (cdr options)
            (cons (cadar options) sofar)
            nilseen))
        (t (defstruct-constructor-name-lst1 name
            (cdr options)
            sofar
            nilseen))))
    (t (defstruct-constructor-name-lst1 name
        (cdr options)
        sofar
        nilseen))))

(defun defstruct-constructor-name-lst
  (name options)
  (defstruct-constructor-name-lst1 name
    options
    nil
    nil))

(defun defstruct-copier-name-lst1
  (name options
    sofar
    nilseen)
  (cond ((endp options) (cond (sofar sofar)
        (nilseen nil)
        (t (list (intern-in-package-of-symbol (string-append "COPY-"
                (symbol-name name))
              name)))))
    ((and (consp (car options))
       (eq ':copier (caar options))
       (consp (cdar options))) (cond ((null (cadar options)) (defstruct-copier-name-lst1 name
            (cdr options)
            sofar
            t))
        ((symbolp (cadar options)) (defstruct-copier-name-lst1 name
            (cdr options)
            (cons (cadar options) sofar)
            nilseen))
        (t (defstruct-copier-name-lst1 name
            (cdr options)
            sofar
            nilseen))))
    (t (defstruct-copier-name-lst1 name
        (cdr options)
        sofar
        nilseen))))

(defun defstruct-copier-name-lst
  (name options)
  (defstruct-copier-name-lst1 name
    options
    nil
    nil))

(defun defstruct-predicate-name-lst1
  (name options
    sofar
    nilseen)
  (cond ((endp options) (cond (sofar sofar)
        (nilseen nil)
        (t (list (intern-in-package-of-symbol (string-append (symbol-name name)
                "-P")
              name)))))
    ((and (consp (car options))
       (eq ':predicate (caar options))
       (consp (cdar options))) (cond ((null (cadar options)) (defstruct-predicate-name-lst1 name
            (cdr options)
            sofar
            t))
        ((symbolp (cadar options)) (defstruct-predicate-name-lst1 name
            (cdr options)
            (cons (cadar options) sofar)
            nilseen))
        (t (defstruct-predicate-name-lst1 name
            (cdr options)
            sofar
            nilseen))))
    (t (defstruct-predicate-name-lst1 name
        (cdr options)
        sofar
        nilseen))))

(defun defstruct-predicate-name-lst
  (name options)
  (defstruct-predicate-name-lst1 name
    options
    nil
    nil))

(defun defstruct-accessors
  (conc-name descs
    package-of-symbol)
  (if (endp descs)
    nil
    (let* ((desc (car descs)) (name (if (consp desc)
            (car desc)
            desc)))
      (if (symbolp name)
        (cons (if (equal conc-name "")
            name
            (intern-in-package-of-symbol (string-append conc-name
                (symbol-name name))
              package-of-symbol))
          (defstruct-accessors conc-name
            (cdr descs)
            package-of-symbol))
        (defstruct-accessors conc-name
          (cdr descs)
          package-of-symbol)))))

(defun defstruct-name-and-fns
  (form)
  (if (not (and (consp form)
        (eq (car form) 'defstruct)
        (consp (cdr form))
        (or (symbolp (cadr form))
          (and (consp (cadr form))
            (symbolp (caadr form))))))
    nil
    (let* ((name-and-options (cadr form)) (name (if (consp name-and-options)
            (car name-and-options)
            name-and-options))
        (options (if (consp name-and-options)
            (cdr name-and-options)
            nil))
        (slot-descs (if (and (consp (cddr form))
              (stringp (caddr form)))
            (cdddr form)
            (cddr form)))
        (conc-name (defstruct-conc-name name
            options))
        (top-fns (append (defstruct-constructor-name-lst name
              options)
            (defstruct-copier-name-lst name
              options)
            (defstruct-predicate-name-lst name
              options)))
        (accessors (defstruct-accessors conc-name
            slot-descs
            name)))
      (cons name
        (append top-fns accessors)))))