-
-
Notifications
You must be signed in to change notification settings - Fork 4
/
toolkit.lisp
77 lines (65 loc) · 3.22 KB
/
toolkit.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
(in-package #:org.shirakumo.deeds)
(defun find-slot-accessor (slot)
(loop for writer in (c2mop:slot-definition-writers slot)
thereis (find writer (c2mop:slot-definition-readers slot)
:test (lambda (a b) (if (listp a) (eql (second a) b) (eql a b))))))
(defun find-class-slot-fuzzy (slot-ish class)
(flet ((name~= (a b)
(or (eql a b) (string= a b))))
(loop for slot in (class-all-direct-slots class)
when (or (name~= slot-ish (c2mop:slot-definition-name slot))
(find slot-ish (c2mop:slot-definition-readers slot) :test #'name~=))
do (return slot))))
(defun find-class-slot-for-compound (slot-ish compound)
(etypecase compound
(cons
(ecase (first compound) (and) (or))
(some (lambda (a) (find-class-slot-for-compound slot-ish a)) (rest compound)))
(symbol (find-class-slot-fuzzy slot-ish compound))))
(defun build-fuzzy-slot-accessor (slot-ish class-ish instance)
(let* ((slot (or (find-class-slot-for-compound slot-ish class-ish)
(error "Don't know how to access the variable ~s in class ~s" slot-ish class-ish)))
(accessor (find-slot-accessor slot)))
(values
(cond (accessor
`(,accessor ,instance))
(T
`(slot-value ,instance ',(c2mop:slot-definition-name slot))))
slot)))
(defmacro with-fuzzy-slot-bindings (vars (instance class-ish) &body body)
`(symbol-macrolet ,(loop for var in vars
collect (destructuring-bind (name &optional (slot-ish name)) (if (listp var) var (list var))
`(,name ,(build-fuzzy-slot-accessor slot-ish class-ish instance))))
,@body))
(defun copy-hash-table (old &key (test (hash-table-test old))
(size (hash-table-size old))
(rehash-size (hash-table-rehash-size old))
(rehash-threshold (hash-table-rehash-threshold old)))
(let ((new (make-hash-table :test test
:size size
:rehash-size rehash-size
:rehash-threshold rehash-threshold)))
(maphash (lambda (k v) (setf (gethash k new) v)) old)
new))
(defun format-time (universal-time)
(multiple-value-bind (s m h dd mm yy) (decode-universal-time universal-time)
(format NIL "~4,'0d.~2,'0d.~2,'0d ~2,'0d:~2,'0d:~2,'0d" yy mm dd h m s)))
(defun removef (list &rest remove-properties)
(loop for (key val) on list by #'cddr
for found = (find key remove-properties)
unless found collect key
unless found collect val))
(defun unlist (a)
(if (listp a) (first a) a))
(defun ensure-list (a &rest elements)
(if (listp a) a (list* a elements)))
(defun compile-lambda (lambda)
(handler-bind ((style-warning #'muffle-warning)
#+sbcl (sb-ext:compiler-note #'muffle-warning))
(compile NIL lambda)))
(defun make-thread (func &optional name)
(bt:make-thread func
:name name
:initial-bindings `((*trace-output* . ,*trace-output*)
(*standard-output* . ,*standard-output*)
(*error-output* . ,*error-output*))))