-
-
Notifications
You must be signed in to change notification settings - Fork 1
/
template.lisp
300 lines (285 loc) · 15.9 KB
/
template.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
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
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
(in-package #:org.shirakumo.type-templates)
;;; Template mechanism
(defmacro define-template (name &rest args)
(let ((template-args (loop until (listp (car args))
collect (pop args)))
(macro-name (gensym "NAME")))
(destructuring-bind (args . body) args
`(defmacro ,(compose-name #\- 'define name) (,@template-args &optional (,macro-name))
(flet ((template-unfulfillable ()
(error 'template-unfulfillable :template ',name :arguments (list ,@template-args))))
(declare (ignorable #'template-unfulfillable))
(let ((body (progn ,@body))
(name (or ,macro-name (compose-name #\/ ',name ,@(loop for arg in template-args
when (char= #\< (char (string arg) 0))
collect arg)))))
`(progn
(declaim (ftype (function ,(loop with types = (declared-variable-types body)
for arg in ',args
collect (or (second (assoc arg types)) 'T))
,(declared-return-type body))
,name)
,@(when (find 'inline (declarations body))
`((inline ,name))))
(defun ,name ,',args
(declare (optimize speed (safety 0) (debug 0) (compilation-speed 0))
,@(remove 'inline (declarations body)))
,@(remove-if #'declaration-p body)))))))))
(defmacro do-combinations (&environment env template &rest argument-combinations)
(destructuring-bind (template &optional name) (enlist template)
`(progn ,@(loop for combination in (apply #'enumerate-combinations argument-combinations)
when (handler-case (funcall (macro-function template env) `(,template ,@combination) NIL)
(template-unfulfillable () NIL))
collect `(,template ,@combination ,@(if name (list (apply #'format-name name combination))))))))
(defmacro do-type-combinations (type template &rest other-template-args)
`(do-combinations ,template ,@other-template-args
,@(loop for arg in (template-arguments type)
for i from 0
collect (delete-duplicates
(loop for instance in (instances type)
collect (nth i (template-arguments instance)))))))
(defmacro do-instance-combinations (template &rest type-templates)
`(do-combinations ,template
,@(loop for type in type-templates
collect (loop for instance in (instances type)
collect (lisp-type instance)))))
(defun merge-identical-branches (branches)
(labels ((recurse (branches)
(let ((pure ()))
(loop for (tt . sub) in branches
for entry = (assoc tt pure)
do (cond (entry
;; Don't merge if the leaf is a branch target and instead
;; prefer the earlier branch target always.
(when (consp sub)
(setf (cdr entry) (append (cdr entry) sub))))
(T
(push (cons tt sub) pure))))
(setf branches (reverse pure)))
(loop for cons in branches
do (when (consp (cdr cons))
(setf (cdr cons) (recurse (cdr cons)))))
branches))
(recurse branches)))
(defun duplicate-subtype-branches (branches)
(labels ((recurse (branches)
(loop for branch in branches
for tt = (car branch)
do (loop for (ott . osub) in branches
do (when (and (not (eq tt ott))
(subtypep tt ott)
(listp (cdr branch)))
;; If this is a subtype, clone all branches of the supertype
(setf (cdr (last branch)) (copy-tree osub)))))
(loop for (tt . sub) in branches
do (when (consp sub) (recurse sub)))
branches))
(recurse branches)))
(defun emit-type-dispatch (args parts)
(let ((tree (merge-identical-branches
(duplicate-subtype-branches
(prefix-tree
(loop for (type rettype . expansion) in parts
for i from 0
collect (append type i)))))))
(labels ((emit-dispatch (args types)
`(etypecase ,(first args)
,@(loop for (type . rest) in types
collect `(,type
,(if (consp rest)
(emit-dispatch (rest args) rest)
(destructuring-bind (rettype . body) (rest (nth rest parts))
(if (eql T rettype)
`(progn ,@body)
`(the (values ,rettype &optional) (progn ,@body))))))))))
(emit-dispatch args tree))))
#+sbcl
(defun emit-transform-dispatch (args parts)
(let ((tree (merge-identical-branches
(duplicate-subtype-branches
(prefix-tree
(loop for (type rettype . expansion) in parts
for i from 0
collect (append type i)))))))
(labels ((emit-dispatch (args types)
`(cond
,@(loop for (type . rest) in types
collect `((sb-kernel:types-equal-or-intersect ,(first args) (sb-kernel:specifier-type ',type))
,(if (consp rest)
(emit-dispatch (rest args) rest)
(destructuring-bind (rettype . body) (rest (nth rest parts))
(if (eql T rettype)
`'(progn ,@body)
`'(the (values ,rettype &optional) (progn ,@body))))))))))
`(let ,(loop for arg in args collect `(,arg (etypecase ,arg
(sb-c::lvar (sb-c::lvar-type ,arg))
(null (sb-kernel:specifier-type 'null))
(cons (sb-kernel:specifier-type 'list)))))
,(emit-dispatch args tree)))))
(defmacro define-type-dispatch (name args &body expansions)
(let* ((argvars (lambda-list-variables args))
(expansions (loop for expansion in expansions
for deficit = (- (length argvars) (length (first expansion)))
do (when (< deficit 0)
(error "Dispatch expansion~% ~s~%contains more variables than specified in the arglist."
expansion))
collect (list* (append (first expansion) (make-list deficit :initial-element 'null))
(rest expansion))))
(argtypes (loop with i = -1
for arg in args
collect (cond ((find arg lambda-list-keywords)
arg)
(T
(incf i)
`(or ,@(delete-duplicates (loop for (args) in expansions collect (nth i args))
:test #'equal))))))
(rettype `(or ,@(delete-duplicates (loop for (args rettype) in expansions collect rettype)
:test #'equal))))
;; KLUDGE: Force &rest to list
(when (find '&rest argtypes)
(setf (elt argtypes (1+ (position '&rest argtypes))) 'T))
`(progn
#-sbcl (declaim (inline ,name))
#-sbcl (declaim (ftype (function ,argtypes (values ,rettype &optional)) ,name))
(defun ,name ,args
(declare (optimize speed (debug 1) (safety 1) (compilation-speed 0)))
,(emit-type-dispatch argvars expansions))
#+sbcl
(sb-c:defknown ,name ,argtypes ,rettype
(sb-c:any)
:overwrite-fndb-silently T)
#++
(sb-c:defoptimizer (,name sb-c:derive-type) (,args)
(let ,(loop for arg in argvars
collect `(,arg (if ,arg (sb-c::lvar-type ,arg) (sb-c::specifier-type 'NULL))))
(cond ,@(loop for (argtypes rettype) in expansions
collect `((and ,@(loop for argtype in argtypes
for arg in argvars
for i from 0
collect `(sb-c::csubtypep ,arg (sb-c::specifier-type ',argtype))))
(sb-c::specifier-type ',rettype)))
(T (sb-c::specifier-type T)))))
;; NOTE: The defoptimizer isn't needed, SBCL can derive the type on its own just fine.
;; FIXME: make this work correctly.
#++
(sb-c:deftransform ,name (,args)
,(emit-transform-dispatch argvars expansions))
#+sbcl
,@(loop for (type result . body) in (reverse expansions)
;; FIXME: this is not great. optional placement should be better.
for opttypes = (remove 'null type)
collect `(sb-c:deftransform ,name (,args ,opttypes)
(dbg "Expanding transform (~a~{ ~a~})" ',name ',opttypes)
',@body)))))
(defmacro define-dependent-dispatch-type (name (type-list i &rest args) &body body)
`(eval-when (:compile-toplevel :load-toplevel :execute)
(defun ,name (,type-list ,i ,@args)
(declare (ignorable ,type-list ,i))
,@body)))
(defun enumerate-template-type-combinations (types)
(labels ((expand-type (type)
(cond ((integerp type)
(list type))
((listp type)
(if (eql 'function (first type))
(lambda (types i)
(apply (fdefinition (first (second type))) types i (rest (second type))))
(loop for sub in type append (expand-type sub))))
((vectorp type)
(list type))
((subtypep type 'template-type)
(instances type))
(T
(list type)))))
(let ((expanded (apply #'enumerate-combinations (mapcar #'expand-type types))))
;; Perform back substitution of positional types
(dolist (types expanded expanded)
(loop for cons on types
for i from 0
do (typecase (car cons)
(integer
(when (= (car cons) i)
(error "Positional reference cannot refer to itself!"))
(setf (car cons) (nth (car cons) types)))
(vector
(setf (car cons) (nth (aref (car cons) 1) (template-arguments (nth (aref (car cons) 0) types)))))
(function
(setf (car cons) (funcall (car cons) types i)))))))))
(defun determine-template-arguments (types)
(remove-duplicates
(loop for type in types
when (typep type 'template-type)
append (template-arguments type))))
(defmacro define-templated-dispatch (name args &body body)
(form-fiddle:with-body-options (expansions options ignore-template-types) body
(assert (null options))
(flet ((full-template-args (types template-args)
(append (loop for arg in template-args
collect (if (vectorp arg)
(nth (aref arg 0) types)
arg))
(determine-template-arguments
(loop for type in types
unless (loop for ignored in ignore-template-types
thereis (eql (type-of type) ignored))
collect type)))))
`(define-type-dispatch ,name ,args
,@(loop for (types template . template-args) in expansions
append (loop for type in (enumerate-template-type-combinations types)
for form = (if (listp template)
`(,(mapcar #'lisp-type type) T
(,(apply #'compose-name #\/ (car template) (full-template-args type (rest template))) ,@template-args))
`(,(mapcar #'lisp-type type) T
(,(apply #'compose-name #\/ template (full-template-args type template-args)) ,@(lambda-list-variables args))))
if (fboundp (car (third form)))
collect form
else do (alexandria:simple-style-warning "Dispatch omitted for ~s as the raw function is undefined."
(car (third form)))))))))
;; NOTE: this does not work with &REST as we cannot automatically deal with
;; conversion or deconversion of variadic arguments as a list in the
;; plain defun.
(defmacro define-alias (fun args &body expansion)
(let* ((argvars (lambda-list-variables args))
(arggens (loop for var in argvars collect (gensym (string var)))))
`(progn
(macrolet ((thunk ()
(let ,(loop for arg in argvars
collect `(,arg ',arg))
,@expansion)))
(defun ,fun ,args
,(form-fiddle:lambda-docstring `(lambda () ,@expansion))
(thunk)))
(define-compiler-macro ,fun ,(loop for arg in args
collect (if (listp arg)
(list (first arg) `',(second arg))
arg))
,(form-fiddle:lambda-docstring `(lambda () ,@expansion))
`(let ,(list ,@(loop for arg in argvars
for gen in arggens
collect `(list ',gen ,arg)))
,(let ,(loop for arg in argvars
for gen in arggens
collect `(,arg ',gen))
,@expansion))))))
(defmacro define-slot-accessor (template-type name slot)
(let ((instances (loop for instance in (instances template-type)
when (ignore-errors (slot instance slot))
collect instance)))
`(progn
(define-type-dispatch ,name (obj)
,@(loop for type in instances
for slot-instance = (slot type slot)
collect `((,(lisp-type type)) ,(lisp-type slot-instance)
,(place-form type slot 'obj))))
(define-type-dispatch (setf ,name) (value obj)
,@(loop for type in instances
for slot-instance = (slot type slot)
unless (read-only slot-instance)
collect `((,(lisp-type slot-instance) ,(lisp-type type)) ,(lisp-type slot-instance)
(setf ,(place-form type slot 'obj) value))
;; Automatically add type converter call if there is one.
unless (or (read-only slot-instance)
(not (symbolp (lisp-type slot-instance)))
(not (fboundp (lisp-type slot-instance))))
collect `((T ,(lisp-type type)) ,(lisp-type slot-instance)
(setf ,(place-form type slot 'obj) (,(lisp-type slot-instance) value))))))))