This repository was archived by the owner on Jul 21, 2021. It is now read-only.
forked from eudoxia0/docparser
-
Notifications
You must be signed in to change notification settings - Fork 3
Expand file tree
/
Copy pathparsers.lisp
More file actions
270 lines (246 loc) · 10.1 KB
/
Copy pathparsers.lisp
File metadata and controls
270 lines (246 loc) · 10.1 KB
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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
(in-package :quickdocs-parser)
(define-parser cl:defun (name (&rest args) &rest body)
(let ((docstring (if (stringp (first body))
(first body)
nil)))
(make-instance 'function-node
:name (if (listp name)
;; SETF name
(second name)
;; Regular name
name)
:docstring docstring
:setfp (listp name)
:lambda-list args)))
(define-parser cl:defmacro (name (&rest args) &rest body)
(let ((docstring (if (stringp (first body))
(first body)
nil)))
(make-instance 'macro-node
:name name
:docstring docstring
:lambda-list args)))
(define-parser cl:defgeneric (name (&rest args) &rest options)
(let ((docstring (second (find :documentation options :key #'first))))
(make-instance 'generic-function-node
:name (if (listp name)
;; SETF name
(second name)
;; Regular name
name)
:docstring docstring
:setfp (listp name)
:lambda-list args)))
(define-parser cl:defmethod (name args-or-specifier &rest body)
(let* ((kind (if (keywordp args-or-specifier)
args-or-specifier
:primary))
(args (if (keywordp args-or-specifier)
(first body)
args-or-specifier))
(body (if (keywordp args-or-specifier)
(rest body)
body))
(docstring (if (stringp (first body))
(first body)
nil)))
(declare (ignore kind))
(make-instance 'method-node
:name (if (listp name)
;; SETF name
(second name)
;; Regular name
name)
:docstring docstring
:setfp (listp name)
:lambda-list args)))
(defun parse-var (form)
(destructuring-bind (name &optional initial-value docstring) form
(declare (ignore initial-value))
(make-instance 'variable-node
:name name
:docstring docstring)))
(define-parser cl:defparameter (&rest form)
(parse-var form))
(define-parser cl:defvar (&rest form)
(parse-var form))
(define-parser cl:defconstant (&rest form)
(parse-var form))
(define-parser cl:deftype (name lambda-list &rest body)
(let ((docstring (if (stringp (first body))
(first body)
nil)))
(make-instance 'type-node
:name name
:docstring docstring
:lambda-list lambda-list)))
(define-parser optima:defpattern (name lambda-list &rest body)
(let ((docstring (if (stringp (first body))
(first body)
nil)))
(make-instance 'optima-pattern-node
:name name
:docstring docstring
:lambda-list lambda-list)))
(define-parser trivia:defpattern (name lambda-list &rest body)
(let ((docstring (if (stringp (first body))
(first body)
nil)))
(make-instance 'trivia-pattern-node
:name name
:docstring docstring
:lambda-list lambda-list)))
(defun parse-slot (slot)
(if (listp slot)
(let ((slot (copy-list slot)))
(flet ((extract-all-and-delete (key)
(let ((out (list)))
(loop while (getf (rest slot) key) do
(push (getf (rest slot) key) out)
(remf (rest slot) key))
out)))
(let ((accessors (extract-all-and-delete :accessor))
(readers (extract-all-and-delete :reader))
(writers (extract-all-and-delete :writer)))
(destructuring-bind (name &key initarg initform type
(allocation :instance)
documentation
;; For metaclass stuff
&allow-other-keys)
slot
(declare (ignore initarg initform))
(make-instance 'class-slot-node
:name name
:docstring documentation
:type type
:allocation allocation
:accessors accessors
:readers readers
:writers writers)))))
(make-instance 'class-slot-node
:name slot)))
(define-parser cl:defclass (name superclasses slots &rest options)
(let ((docstring (second (find :documentation options :key #'first))))
(make-instance 'class-node
:name name
:superclasses superclasses
:slots (loop for slot in slots collecting
(parse-slot slot))
:docstring docstring)))
(define-parser cl:define-condition (name superclasses slots &rest options)
(let ((docstring (second (find :documentation options :key #'first))))
(make-instance 'condition-node
:name name
:superclasses superclasses
:slots (loop for slot in slots collecting
(parse-slot slot))
:docstring docstring)))
(defun parse-struct-slot (slot)
(let ((name (if (listp slot)
(first slot)
slot)))
(make-instance 'struct-slot-node
:name name)))
(define-parser cl:defstruct (name-and-options &rest slots)
(let ((name (if (listp name-and-options)
(first name-and-options)
name-and-options))
(docstring (if (stringp (first slots))
(first slots)
nil))
(slots (if (stringp (first slots))
(rest slots)
slots)))
(make-instance 'struct-node
:name name
:docstring docstring
:slots (loop for slot in slots collecting
(parse-struct-slot slot)))))
;;; CFFI parsers
(define-cffi-parser :defcfun (name-and-options return-type &rest args)
(let ((name (if (listp name-and-options)
(first (remove-if-not #'symbolp name-and-options))
name-and-options))
(docstring (if (stringp (first args))
(first args)
nil))
(args (if (stringp (first args))
(rest args)
nil)))
(make-instance 'cffi-function
:name name
:docstring docstring
:return-type return-type
:lambda-list args)))
(define-cffi-parser :defctype (name base-type &optional docstring)
(make-instance 'cffi-type
:name name
:docstring docstring
:base-type base-type))
(defun parse-cffi-slot (form)
(destructuring-bind (name type &rest rest) form
(declare (ignore rest))
(make-instance 'cffi-slot
:name name
:type type)))
(define-cffi-parser :defcstruct (name-and-options &rest doc-and-slots)
(let ((name (if (listp name-and-options)
(first name-and-options)
name-and-options))
(docstring (if (stringp (first doc-and-slots))
(first doc-and-slots)
nil))
(slots (if (stringp (first doc-and-slots))
(rest doc-and-slots)
nil)))
(make-instance 'cffi-struct
:name name
:docstring docstring
:slots (loop for slot in slots collecting
(parse-cffi-slot slot)))))
(define-cffi-parser :defcunion (name &rest doc-and-slots)
(let ((docstring (if (stringp (first doc-and-slots))
(first doc-and-slots)
nil))
(slots (if (stringp (first doc-and-slots))
(rest doc-and-slots)
nil)))
(make-instance 'cffi-union
:name name
:docstring docstring
:variants (loop for slot in slots collecting
(parse-cffi-slot slot)))))
(define-cffi-parser :defcenum (name-and-options &rest enum-list)
(let ((name (if (listp name-and-options)
(first name-and-options)
name-and-options))
(docstring (if (stringp (first enum-list))
(first enum-list)
nil))
(enum-list (if (stringp (first enum-list))
(rest enum-list)
nil)))
(make-instance 'cffi-enum
:name name
:docstring docstring
:variants (loop for variant in enum-list collecting
(if (listp variant)
(first variant)
variant)))))
(define-cffi-parser :defbitfield (name-and-options &rest masks)
(let ((name (if (listp name-and-options)
(first name-and-options)
name-and-options))
(docstring (if (stringp (first masks))
(first masks)
nil))
(masks (if (stringp (first masks))
(rest masks)
nil)))
(make-instance 'cffi-bitfield
:name name
:docstring docstring
:masks (loop for mask in masks collecting
(if (listp mask)
(first mask)
mask)))))