(in-package #:cl-user)

;;;; Utilities for `association'

#+clisp
(eval-when (:compile-toplevel :load-toplevel :execute)
  (import '(ext:with-collect ext:with-gensyms)))

;;these definitions were borrowed from CLOCC
#-clisp
(defmacro with-collect ((&rest collectors) &body forms)
  "Evaluate forms, collecting objects into lists.
Within the FORMS, you can use local macros listed among collectors,
they are returned as multiple values.
E.g., (with-collect (c1 c2) (dotimes (i 10) (if (oddp i) (c1 i) (c2 i))))
 ==> (1 3 5 7 9); (0 2 4 6 8) [2 values]"
  (let ((ret (mapcar (lambda (cc) (gensym (format nil "~s-RET-" cc)))
                     collectors))
        (tail (mapcar (lambda (cc) (gensym (format nil "~s-TAIL-" cc)))
                      collectors))
        (tmp (mapcar (lambda (cc) (gensym (format nil "~s-TMP-" cc)))
                     collectors)))
    `(let (,@ret ,@tail)
      (declare (list ,@ret ,@tail))
      (macrolet ,(mapcar (lambda (co re ta tm)
                           `(,co (form)
                             `(let ((,',tm (list ,form)))
                               (if ,',re (setf (cdr ,',ta) (setf ,',ta ,',tm))
                                   (setf ,',re (setf ,',ta ,',tm))))))
                         collectors ret tail tmp)
        ,@forms
        (values ,@ret)))))

#-clisp
(defmacro with-gensyms ((title &rest names) &body body)
  "Bind symbols in NAMES to gensyms.  TITLE is a string - `gensym' prefix.
Inspired by Paul Graham, <On Lisp>, p. 145."
  `(let (,@(mapcar (lambda (sy)
                     `(,sy (gensym ,(concatenate 'string title
                                                 (symbol-name sy) "-"))))
                   names))
     ,@body))

(defun once-only-bindings (form-list)
  "From FORM-LIST, answer three values:
* A list of variable names, all uninterned symbols.
* A list of value-forms to bind to said variables, per the following:
* FORM-LIST, but with the non-constant forms replaced by
  references to variables in the primary value, each of which in
  turn matches the original value form in the secondary value.
  As such, using these forms expects that the variables in the
  primary value are bound to the values from the secondary form."
  (with-collect (var! form! form-list!)
    (dolist (elt-form form-list)
      (if (constantp elt-form)
	(form-list! elt-form)
	(let ((var (gensym (prin1-to-string elt-form))))
	  (var! var)
	  (form! elt-form)
	  (form-list! var))))))

(defun association (alist key &rest keys)
  (declare (ignore keys))	;key semantics?
  (cdr (assoc key alist)))

(define-setf-expander association (alist key &rest keys &environment env)
  (multiple-value-bind (temps temp-vals store-vars store-form access-form)
      (get-setf-expansion alist env)
    (with-gensyms ("SA-" association alist-var key-var assoc-result)
      (destructuring-bind (store-var) store-vars
	(multiple-value-bind (evalled-key-vars evalled-key-forms keys)
	    (once-only-bindings keys)
	  ;; we don't deal with actually using the keywords yet
	  (declare (ignore keys))
	  (values `(,@temps ,alist-var ,key-var ,@evalled-key-vars
			    ,assoc-result)
		  `(,@temp-vals ,access-form ,key ,@evalled-key-forms
				(assoc ,key-var ,alist-var))
		  (list association)
		  `(if ,assoc-result
		     (setf (cdr ,assoc-result) ,association)
		     (let ((,store-var
			     (acons ,key-var ,association ,alist-var)))
		       ,store-form
		       ,association))
		  `(cdr ,assoc-result)))))))