;;;; Fun with macros and custom accessors in Common Lisp
;;;; These do not use the Meta-Object Protocol.


(declaim
 (optimize (speed 3) (safety 1)))


(defun db-defstruct-filter-key (lst)
  (let ((res nil))
    (do ((e lst (nthcdr 2 e)))
	((or (null (first e)) (null (second e))) t)
      (let ((key (first e)) (val (second e)))
	(if (not (eq key ':%id))
	    (progn
	      (push val res)
	      (push key res)))))
    res))


(defmacro db-defstruct-p (structure)
  (let ((newp (intern (format nil "DB-~S-P" structure)))
	(oldp (intern (format nil "~S-P" structure))))
    `(progn
       (declaim (inline ,newp))
       (defun ,newp (o)
	 (,oldp o)))))

(defmacro db-defstruct-constructor (structure)
  (let ((newconstructor (intern (format nil "DB-MAKE-~S" structure)))
	(oldconstructor (intern (format nil "MAKE-~S" structure))))
    `(progn
       (defun ,newconstructor (&rest parameters)
	 (let* ((valid (db-defstruct-filter-key parameters))
		(instance (apply #',oldconstructor valid)))
	   (db-constructor ',structure instance valid)
	   instance)))))

(defmacro db-defstruct-accessor (structure slot)
  (let ((newslot (intern (format nil "DB-~S-~S" structure slot)))
	(oldslot (intern (format nil "~S-~S" structure slot))))
    `(progn
       (defun ,newslot (o)
	 (,oldslot o))
       (defun (setf ,newslot) (v o)
	 (let ((res (db-fset ',structure ',slot o (,oldslot o) v)))
	   (setf (,oldslot o) res)
	   res)))))

(defmacro db-defstruct (structure &rest slots)
  (let* ((validslots
	  (remove-if #'(lambda (e) (eq (first e) '%id)) slots))
	 (accessors
	  (mapcar #'(lambda (e)
		      `(db-defstruct-accessor ,structure ,(first e)))
		  validslots)))
    `(progn
       (defstruct ,structure
	 (%id nil)
	 ,@validslots)
       (db-defstruct-constructor ,structure)
       (db-defstruct-p ,structure)
       ,@accessors
       (db-defstruct-function ',structure ',slots))))


(defun db-defstruct-function (structure &rest slots)
  (format t "; Creating structure of type ~S with slots ~S~%"
	  structure slots)
  t)

(defun db-constructor (structure object &rest parameters)
  (declare (ignore parameters))
  (format t "; Constructing object of type ~S: ~S~%" structure object))

(defun db-fset (structure slot object oldvalue value)
  (declare (ignore object))
  (format t "; Assigning ~S over ~S for slot ~S of type ~S~%"
	  value oldvalue slot structure)
  value)