homedirectory

    (defun compute-hash (key hash f)
      "Get the value for KEY in HASH or compute it with F, enter into HASH and return."
      (multiple-value-bind (val win)
          (gethash key hash)
        (if win
            val
            (setf (gethash key hash) (funcall f key)))))

    (defun memoized (f)
      (let ((cache (make-hash-table)))
        (flet ((memo (x g) (compute-hash x cache g)))
          (lambda (&rest args) (apply f #'memo args)))))

    (defun fib (n)
      (if (<= n 1)
          n
          (+ (fib (1- n)) (fib (- n 2)))))

    ;; MEMO is a function that takes a key and a computing function.
    ;; If a key has been memoized, it returns the cached value, otherwise it calls the computing
    ;; function with the key and caches the result.
    (let ((example (memoized (lambda (memo x)
                               (format t "X: ~a~%" x)
                               (let ((result (funcall memo x #'fib)))
                                 (format t "~a~%" (* 2 result)))))))
      (trace fib)
      (funcall example 5)
      (funcall example 5)
      (funcall example 5)
      (untrace fib))

    (apply (symbol-function ',our-setf-function-name)
           (cons ,new-value ,@(cdr locator)))

    (apply (symbol-function '|(our-setf head)|) 
           (cons 0 (list 1 2)))

    (our-setf (aref a 23) 0)

    (|(our-setf aref)| (cons 0 a 23))

    (apply (symbol-function ',our-setf-function-name)
           (list ,new-value ,@(cdr locator)))

    (funcall (symbol-function ',our-setf-function-name)
             ,new-value ,@(cdr locator))

    (funcall ',our-setf-function-name ,new-value ,@(cdr locator))

    (defgeneric |(OUR-SETF HEAD)| (new-value place))

    (defmethod |(OUR-SETF HEAD)| (new-value (place list)) 
      (rplaca place new-value)
      new-value)

    (defmacro our-setf (locator new-value)
      (let* ((selector (car locator))
             ; use the selector's package,
             ; selector must be interned
             (our-setf-function-name (intern (format nil "(OUR-SETF ~a)"
                                              selector) 
                                     (symbol-package selector))))
        `(funcall ',our-setf-function-name
                  ,new-value ,@(cdr locator))))

    (eval-when (:compile-toplevel :load-toplevel :execute)
      (defun selector-symbol (selector)
        (or (get selector 'our-setf-name)
            (gentemp (string selector) (symbol-package selector)))))

    (defmacro defgeneric-setf ((selector &rest selector-params) (new-value))
      (let ((name (selector-symbol selector)))
        `(progn
           (setf (get ',selector 'our-setf-name) ',name)
           (defgeneric ,name (,new-value ,@selector-params)))))

    (defmacro defmethod-setf ((selector &rest selector-params) (new-value) &body body)
      (let ((name (selector-symbol selector)))
        `(progn
           (setf (get ',selector 'our-setf-name) ',name)
           (defmethod ,name (,new-value ,@selector-params)
             ,@body))))

    (defmacro our-setf ((selector &rest selector-params) new-value)
      (let ((our-setf-function-name (selector-symbol selector)))
        `(funcall ',our-setf-function-name ,new-value ,@selector-params)))

    (defgeneric-setf (head x) (new-value))

    (defmethod-setf (head (x cons)) (new-value)
      (rplaca x new-value)
      new-value)

    #+nil
    (let ((xs (list 1 2))) 
      ; expands to (funcall 'headN 0 xs) where N is a number from GENTEMP
      (our-setf (head xs) 0) 
      xs) ; => (0 2)

    (defgeneric-setf (our-elt seq idx) (new-value))

    (defmethod-setf (our-elt (seq list) idx) (new-value)
      (loop for i from 0 to idx
            for cons on seq
            finally (our-setf (head cons) new-value))
      new-value)

    #+nil
    (let ((xs (list 'a 'b 'c))) 
      ; expands to (funcall 'our-eltN 'k xs 1) where N is a number from GENTEMP
      (our-setf (our-elt xs 1) 'k) 
      xs) ; => (a k c)