(in-package "CL-USER")

;;
;; processing of defstructs
;; refers to comp-1.lisp
;;
;;
;;



;; clear hashes

(defun clear-struct-tables ()

  (setf *struct-accessor-expanders* nil)

  (setf *struct-size-table* nil)
  (setf *struct-fields-table* nil)
  (setf *struct-fields-inits-table* nil))

 
(clear-struct-tables)


;; struct accessor hash

(defun is-struct-accessor (head)
  (assoc head *struct-accessor-expanders*))

(defun get-struct-accessor-val (head)
  (cdr (assoc head *struct-accessor-expanders*)))

(defun rewrite-struct-accessor (e)
  (expand `(%svref ,(cadr e) ,(cdr (assoc (car e) *struct-accessor-expanders*)))))

(defun enter-accessor (sym offset)
  (push (cons sym offset) *struct-accessor-expanders*))



;; struct size hash


(defun get-struct-size (strct)
  (let ((r (assoc strct *struct-info-table*)))
    (if r (cdr r)
      nil)))


;; struct fields hash


(defun get-struct-fields (strct)
  (let ((r (assoc strct *struct-fields-table*)))
    (if r (cdr r)
      nil)))

(defun set-struct-fields (strct field-list)
  (push (cons strct field-list) *struct-fields-table*))



;; struct fields-inits hash


(defun get-struct-fields-inits (strct)
  (let ((r (assoc strct *struct-fields-inits-table*)))
    (if r (cdr r)
      nil)))

(defun set-struct-fields-inits (strct field-list)
  (push (cons strct field-list) *struct-fields-inits-table*))






(defun defstruct-expand (e)
  (let ((init-info (cadr e))
        (fields (cddr e)))
    (let ((struct-name (if (listp init-info)
                           (car init-info)
                         init-info)))
      (let ((offset 1)
            (incl nil)
            (conc-name (concatenate 'string (symbol-name struct-name) "-"))
            (predicate (intern (concatenate 'string (symbol-name struct-name) "-p"))))
        (if (listp init-info)
            (do ((l (cdr init-info) (cdr l)))
                ((null l))
              (format t "l = ~a~%" l)
              (case (car (car l))
                ((:include) (setf incl (cadr (car l))))
                ((:conc-name) (setf conc-name 
                                    (if (cadr (car l))
                                        (symbol-name (cadr (car l)))
                                      "")))
                ((:predicate) (setf predicate (cadr (car l)))))))
              
        (format t "incl = ~a~%" incl)
        (when incl
          (do ((p (get-struct-fields incl) (cdr p))
               (i offset (+ i 1)))
              ((null p))
            (enter-accessor (intern (concatenate 'string conc-name (symbol-name (car p)))) i)
            (setf offset (+ offset 1))))
        
        (when (stringp (car fields))
          (setf fields (cdr fields)))
        
        (let ((own-fields-names (mapcar #'(lambda (z) (if (symbolp z) z (car z))) fields))
              (fields-inits (mapcar #'(lambda (z) (if (listp z) (cadr z) nil)) fields)))
          
          (format t "sftab = ~a~%" *struct-fields-table*)
          (format t "*** incl = ~a ~% fields = ~a~%" incl (get-struct-fields incl))

          (set-struct-fields struct-name (append (get-struct-fields incl) own-fields-names))

          (setf fields-inits (append (get-struct-fields-inits incl) fields-inits))
          
          (set-struct-fields-inits struct-name fields-inits)
          
          (do ((p own-fields-names (cdr p)))
              ((null p))
            (enter-accessor (intern (concatenate 'string conc-name (symbol-name (car p)))) offset)
            (setf offset (+ offset 1)))

          (let* ((make-name (intern (concatenate 'string "MAKE-" (symbol-name struct-name))))
                 (res
                   `(progn
                      (defun ,make-name ()
                        (%print ,offset)
                        (let ((v (%make-vector ,offset)))
                          ,@(do ((i 1 (+ i 1))
                                (res nil res))
                               ((>= i offset) (reverse res))
                             (push `(%set-svref v ,i ,(nth (- i 1) fields-inits)) res))
                          v)))))
                 res))))))

          
          
              
   
        




(defun setf-expand (e)
  (let* ((assign-list (cdr e))
         (res
          (do ((p assign-list (cddr p))
               (res nil))
              ((null p)(reverse res))
            (push (setf-1-expand (car p) (cadr p)) res))))
    (if (length=1 res)
        (car res)
      (cons 'progn res))))

(defun setf-1-expand (lval val)
  (if (symbolp lval)
      `(setq ,lval ,val)
    (if (listp lval)
        (let ((head (car lval))
              (obj (cadr lval)))
          (if (eq head 'char)
              (expand `(set-char ,(cadr lval) ,(caddr lval) ,val))
            (if (is-struct-accessor head)
                (expand `(%set-svref ,obj ,(get-struct-accessor-val head) ,val))
              (error "setf-1-expand: 000: no struct accessor found"))))
      (error "setf-1-expand: 001: case not implemented"))))
          
            
(setf *s1* '(defstruct pt x y z))
(setf *s2* '(defstruct (pt2 (:include pt)) u (v 23) w))

(print (defstruct-expand *s1*))
(print (defstruct-expand *s2*))

(print *struct-fields-table*)
(print *struct-accessor-expanders*)

(print (setf-expand '(setf (pt2-x obj1) 12)))

(print (rewrite-struct-accessor '(pt2-u obj)))