(proclaim '(optimize (debug 3)))

(in-package :hu.caleb)

(defgeneric slot-copy-function (class-name slot-name))

(defmethod slot-copy-function (class-name slot-name)
  #'identity)

(defmacro set-copy-function (class-name slot-name func)
  `(defmethod slot-copy-function ((cn (eql ',class-name)) (sn (eql ',slot-name)))
     ,func))
  
(defgeneric copy-instance (obj))

(defmethod copy-instance (obj)
  (let* ((rv (allocate-instance (class-of obj)))
         (slots (clos:class-slots (class-of obj)))
         (instance-slots (remove-if-not (lambda (slot) (eq (clos:slot-definition-allocation slot) :instance))
                                        slots))
         (instance-slot-names (mapcar #'clos:slot-definition-name instance-slots)))
    (loop for slot-name in instance-slot-names
          do (setf (slot-value rv slot-name)
                   (funcall (slot-copy-function (class-name (class-of obj)) slot-name)
                            (slot-value obj slot-name))))
    rv))


;; TODO: patch arnesi to export special-declaration-form

(defun special-variable-names (form)
  (let ((special-declarations (remove-if-not (lambda (decl)
                                               (eq (type-of decl) 'arnesi::special-declaration-form))
                                             (slot-value form 'arnesi:declares))))
    (mapcar (lambda (decl) (slot-value decl 'arnesi:name)) special-declarations)))

(defun dynamic-value-of-variable (name)
  (eval `(locally
           (declare (special ,name))
           ,name)))

(defun set-dynamic-value-of-variable (name value)
  (eval `(locally
           (declare (special ,name))
           (setq ,name value))))

;; Usage:
;; (catch-and-handle ('tag (thrown-values) (append thrown-values thrown-values))
;;                   (throw 'tag (values 3 4)))
;;
;; will call the lambda form in the first arg if something was thrown to 'tag.

(defmacro catch-and-handle ((tag handler-lambda-list &body handler-body) &body body)
  (let ((was-exception-symbol (gensym))
        (tag-symbol (gensym))
        (result-symbol (gensym)))
    `(let* ((,was-exception-symbol t)
            (,tag-symbol ,tag)
            (,result-symbol (multiple-value-list (catch ,tag-symbol
                                                   (multiple-value-prog1
                                                       (progn
                                                         ,@body)
                                                     (setq ,was-exception-symbol nil))))))
       (if ,was-exception-symbol
         (funcall (lambda ,handler-lambda-list ,@handler-body) ,result-symbol)
         (apply #'values ,result-symbol)))))


;; TODO: This is LispWorks 4.4 specific.

(defun globally-special-p (varname)
  (eq (cl::variable-information varname) :special))

(defun contact-email ()
  (let* ((chars '(#\b #\l #\t #\@ #\s #\c #\h #\. #\b #\m #\e #\. #\h #\u))
         (rv (make-string (length chars))))
    (loop for i from 0 below (length chars)
          do (setf (aref rv i) (nth i chars)))
    rv))