/[caleb]/src/utils.lisp
ViewVC logotype

Contents of /src/utils.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 34 - (show annotations)
Thu Jan 10 21:43:28 2008 UTC (6 years, 3 months ago) by blt
File size: 3048 byte(s)
- added contact email printer
1
2 (proclaim '(optimize (debug 3)))
3
4 (in-package :hu.caleb)
5
6 (defgeneric slot-copy-function (class-name slot-name))
7
8 (defmethod slot-copy-function (class-name slot-name)
9 #'identity)
10
11 (defmacro set-copy-function (class-name slot-name func)
12 `(defmethod slot-copy-function ((cn (eql ',class-name)) (sn (eql ',slot-name)))
13 ,func))
14
15 (defgeneric copy-instance (obj))
16
17 (defmethod copy-instance (obj)
18 (let* ((rv (allocate-instance (class-of obj)))
19 (slots (clos:class-slots (class-of obj)))
20 (instance-slots (remove-if-not (lambda (slot) (eq (clos:slot-definition-allocation slot) :instance))
21 slots))
22 (instance-slot-names (mapcar #'clos:slot-definition-name instance-slots)))
23 (loop for slot-name in instance-slot-names
24 do (setf (slot-value rv slot-name)
25 (funcall (slot-copy-function (class-name (class-of obj)) slot-name)
26 (slot-value obj slot-name))))
27 rv))
28
29
30 ;; TODO: patch arnesi to export special-declaration-form
31
32 (defun special-variable-names (form)
33 (let ((special-declarations (remove-if-not (lambda (decl)
34 (eq (type-of decl) 'arnesi::special-declaration-form))
35 (slot-value form 'arnesi:declares))))
36 (mapcar (lambda (decl) (slot-value decl 'arnesi:name)) special-declarations)))
37
38 (defun dynamic-value-of-variable (name)
39 (eval `(locally
40 (declare (special ,name))
41 ,name)))
42
43 (defun set-dynamic-value-of-variable (name value)
44 (eval `(locally
45 (declare (special ,name))
46 (setq ,name value))))
47
48 ;; Usage:
49 ;; (catch-and-handle ('tag (thrown-values) (append thrown-values thrown-values))
50 ;; (throw 'tag (values 3 4)))
51 ;;
52 ;; will call the lambda form in the first arg if something was thrown to 'tag.
53
54 (defmacro catch-and-handle ((tag handler-lambda-list &body handler-body) &body body)
55 (let ((was-exception-symbol (gensym))
56 (tag-symbol (gensym))
57 (result-symbol (gensym)))
58 `(let* ((,was-exception-symbol t)
59 (,tag-symbol ,tag)
60 (,result-symbol (multiple-value-list (catch ,tag-symbol
61 (multiple-value-prog1
62 (progn
63 ,@body)
64 (setq ,was-exception-symbol nil))))))
65 (if ,was-exception-symbol
66 (funcall (lambda ,handler-lambda-list ,@handler-body) ,result-symbol)
67 (apply #'values ,result-symbol)))))
68
69
70 ;; TODO: This is LispWorks 4.4 specific.
71
72 (defun globally-special-p (varname)
73 (eq (cl::variable-information varname) :special))
74
75 (defun contact-email ()
76 (let* ((chars '(#\b #\l #\t #\@ #\s #\c #\h #\. #\b #\m #\e #\. #\h #\u))
77 (rv (make-string (length chars))))
78 (loop for i from 0 below (length chars)
79 do (setf (aref rv i) (nth i chars)))
80 rv))
81

  ViewVC Help
Powered by ViewVC 1.1.5