-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathclos-helpers.lisp
127 lines (117 loc) · 6.09 KB
/
clos-helpers.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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
(in-package #:fwoar.lisputils)
(defmacro with-accessors* ((&rest accessors) object &body body)
`(with-accessors ,(ensure-mapping accessors) ,object
,@body))
(defmacro keys ((op &rest args))
(multiple-value-bind (positional keywords) (split-at '&key args)
`(,op
,@positional
,@(mapcan (lambda (_1)
(list (alexandria:make-keyword _1)
_1))
(cdr keywords)))))
(defmacro new (class &rest initializer-syms)
(multiple-value-bind (required optional rest) (parse-ordinary-lambda-list initializer-syms)
(when optional
(error "new doesn't handle optional arguments"))
(if rest
`(make-instance ,class
,@(mapcan (lambda (_1)
(list (alexandria:make-keyword _1)
_1))
required)
,(make-keyword rest) ,rest)
`(make-instance ,class
,@(mapcan (lambda (_1)
(list (alexandria:make-keyword _1)
_1))
initializer-syms)))))
(defmacro defclass+ (name (&rest super) &body (direct-slots &rest options))
(let (constructor-type defclass-options)
(mapc (lambda (option)
(case (car option)
((:constructor-type) (setf constructor-type (cadr option)))
(t (push option defclass-options))))
options)
(let* ((initargs (append (mapcan (lambda (class)
(typecase class
(cons (mapcar (lambda (it)
(list it nil))
(cadr class)))
(t nil)))
super)
(mapcan (lambda (slot)
(alexandria:ensure-list
(alexandria:when-let ((initarg (getf (cdr slot)
:initarg)))
(fw.lu:prog1-bind
(it (list
(list (intern (symbol-name initarg))
(eq :missing
(getf (cdr slot)
:initform
:missing)))))))))
direct-slots))))
(destructuring-bind (required optional)
(loop for it in initargs
if (second it) collect (first it) into required
else collect (first it) into optional
finally (return (list required
optional)))
(let ((passed-args (mapcar (lambda (it)
(intern (concatenate 'string
(symbol-name it)
"-P")))
optional)))
`(progn (defclass ,name
,(mapcar (lambda (it)
(typecase it
(cons (car it))
(t it)))
super)
,direct-slots
,@(nreverse defclass-options))
(defun ,name (,@required ,@(when optional
(list* '&optional
(mapcar (lambda (it it-p)
`(,it nil ,it-p))
optional
passed-args))))
(declare (optimize (speed 3) (debug 1)))
,(if optional
(let ((heads (reverse (inits optional))))
`(cond ,@(mapcar (lambda (it it-p)
`(,it-p (fw.lu:new ',name ,@required ,@it)))
heads
passed-args)
(t (fw.lu:new ',name ,@required))))
`(fw.lu:new ',name ,@required ,@optional)))))))))
(defun-ct %constructor-name (class)
(let ((*print-case* (readtable-case *readtable*)))
(format nil "~a-~a" '#:make class)))
(defmacro make-constructor (class &rest args)
(destructuring-bind (class &optional (constructor-name (intern (%constructor-name class))))
(ensure-list class)
`(defgeneric ,constructor-name (,@args)
(:method (,@args)
(new ',class ,@args)))))
(defclass hashtable-slot-mixin ()
((%doc :reader hsm-doc :initarg :doc)))
(defmethod c2mop:slot-value-using-class :before (class (object hashtable-slot-mixin) slotd)
(let ((slot-name (c2mop:slot-definition-name slotd)))
(unless (or (eql slot-name '%doc)
(c2mop:slot-boundp-using-class class object slotd))
(let* ((doc (hsm-doc object))
(doc-value (gethash (substitute #\_ #\-
(string-downcase
(symbol-name slot-name)))
doc)))
(setf (slot-value object slot-name) doc-value)))))
(defmacro define-printer (class &body options)
(alexandria:with-gensyms (s)
`(defmethod print-object ((,class ,class) ,s)
(print-unreadable-object (,class ,s :type t :identity t)
,(destructuring-bind (name value) (car options)
`(format ,s "~a: ~s" ,name (,value ,class)))
,@(loop for (name value) in (cdr options)
collect `(format ,s ", ~a: ~s" ,name (,value ,class)))))))