repos
/
cl-unification
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Minor changes (added COPYING information and other minutiae).
Annotate for file /templates-hierarchy.lisp
2009-04-15 mantoniotti
1
;;;; -*- Mode: Lisp -*-
10:18:59 '
2
'
3
;;;; templates-hierarchy.lisp --
2004-11-17 mantoniotti
4
2011-04-02 mantoniotti
5
;;;; See file COPYING for copyright licensing information.
04:05:18 '
6
2004-11-17 mantoniotti
7
(in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
22:19:54 '
8
'
9
;;; Templates.
'
10
;;; Essentially we extend the type specifier language.
'
11
;;; The interesting thing is that we need to specify how a "match"
'
12
;;; between a template and a CL object is performed.
'
13
'
14
;;; A template is one of the following
'
15
;;;
'
16
;;; <template> ::= <logical variable>
'
17
;;; | <structure template>
'
18
;;; | <instance template>
'
19
;;; | <destructuring template>
'
20
;;; | <vector template>
'
21
;;; | <sequence template>
'
22
;;; | <array template>
'
23
;;; | <type template>
'
24
;;; | <lisp object>
'
25
;;;
'
26
'
27
;;; Destructuring Template Lambda List (as per standard CL terminology)
'
28
;;;
'
29
;;; <destructuring template lambda list> ::= <a "destructuring LL" with <template> in lieu of <var>>
'
30
'
31
;;; Templates for Structures and Instances
'
32
;;;
'
33
;;; <structure template> ::= (<class designator> <structure-slot-spec>*)
'
34
;;;
'
35
;;; <instance template> ::= (<class designator> <slot-spec>*)
'
36
;;;
'
37
;;; where
'
38
;;;
'
39
;;; <structure-slot-spec> ::= <reader-name> <template>
'
40
;;; <instance-slot-spec> ::= <accessor-name> <template>
'
41
;;; | (slot-value <slot-name>) <template>
'
42
'
43
;;; Template for Sequences
'
44
;;;
'
45
;;; <sequence template> ::= (<container type> . <destructuring template lambda list>)
'
46
;;; | (subseq <from> <to> . <destructuring template lambda list>)
'
47
;;; <container type> ::= list | cons | vector | array
'
48
'
49
;;; Templates for Vectors and Arrays.
'
50
;;;
'
51
;;; <vector template> ::= (vector . <destructuring template lambda list>)
'
52
;;;
'
53
;;; <array template> ::= (array <shape template>)
'
54
;;; | (<array CL type specifier> <shape template>)
'
55
;;; | (array (['*' | <element type>] [<dimension spec>]]) <shape template>)
'
56
;;; | (aref <index template> <template>)
'
57
;;; <shape template> ::= <destructuring template lambda list>
'
58
;;; | <sequence template>
'
59
;;; | (<shape template>)
'
60
'
61
;;; Templates for LIST and CONS
'
62
;;; <list template> ::= (list . <destructuring template lambda list>)
'
63
;;; <cons template> ::= (cons <template> <template>)
'
64
'
65
;;; A regular list or cons acts as a list (hence as a sequence) template, or a cons template.
'
66
'
67
(define-condition unification-template-error (simple-error)
'
68
())
'
69
'
70
;;; Templates are introduced by the reader macro #T(...)
'
71
'
72
(defclass template ()
'
73
((spec :accessor template-spec :type (or symbol cons) :initarg :spec))
'
74
(:default-initargs :spec nil))
'
75
'
76
(defgeneric template-p (x)
'
77
(:method ((x template)) t)
'
78
(:method ((x t)) nil))
'
79
'
80
'
81
(defclass type-template (template) ())
'
82
'
83
(defgeneric type-template-p (x)
'
84
(:method ((x type-template)) t)
'
85
(:method ((x t)) nil))
'
86
'
87
'
88
(defgeneric type-template-type-spec (x)
'
89
(:method ((x type-template))
'
90
(let ((spec (template-spec x)))
'
91
(if spec
'
92
(first spec)
'
93
'null))))
'
94
'
95
'
96
'
97
(defclass nil-template (type-template) ()) ; This is the point where we break the type hierarchy.
'
98
'
99
(defgeneric nil-template-p (x)
'
100
(:method ((x nil-template)) t)
'
101
(:method ((x t)) nil))
'
102
'
103
'
104
(defclass expression-template (template) ())
'
105
'
106
(defgeneric expression-template-p (x)
'
107
(:method ((x expression-template)) t)
'
108
(:method ((x t)) nil))
'
109
'
110
2010-02-07 pix
111
(defmethod print-object ((template template) stream)
2004-11-17 mantoniotti
112
(format stream "#T~S" (template-spec template)))
22:19:54 '
113
'
114
'
115
(defclass sequence-template (type-template) ())
'
116
'
117
(defgeneric sequence-template-p (x)
'
118
(:method ((x sequence-template)) t)
'
119
(:method ((x t)) nil))
'
120
'
121
'
122
(defclass list-template (sequence-template) ())
'
123
'
124
(defgeneric list-template-p (x)
'
125
(:method ((x list-template)) t)
'
126
(:method ((x t)) nil))
'
127
2009-04-15 mantoniotti
128
10:18:59 '
129
(defclass lambda-template (list-template expression-template) ())
'
130
'
131
(defgeneric lambda-template-p (x)
'
132
(:method ((x lambda-template)) t)
'
133
(:method ((x t)) nil))
'
134
'
135
'
136
2004-11-17 mantoniotti
137
(defclass array-template (type-template) ())
22:19:54 '
138
'
139
(defgeneric array-template-p (x)
'
140
(:method ((x array-template)) t)
'
141
(:method ((x t)) nil))
'
142
'
143
'
144
(defclass vector-template (sequence-template array-template) ())
'
145
'
146
(defgeneric vector-template-p (x)
'
147
(:method ((x vector-template)) t)
'
148
(:method ((x t)) nil))
'
149
'
150
'
151
(defclass string-template (vector-template) ())
'
152
'
153
(defgeneric string-template-p (x)
'
154
(:method ((x string-template)) t)
'
155
(:method ((x t)) nil))
'
156
'
157
'
158
'
159
'
160
(defclass symbol-template (type-template) ())
'
161
'
162
(defgeneric symbol-template-p (x)
'
163
(:method ((x symbol-template)) t)
'
164
(:method ((x t)) nil))
'
165
'
166
'
167
(defclass number-template (type-template) ())
'
168
'
169
(defgeneric number-template-p (x)
'
170
(:method ((x number-template)) t)
'
171
(:method ((x t)) nil))
'
172
'
173
'
174
(defclass structure-object-template (type-template) ())
'
175
'
176
(defgeneric structure-object-template-p (x)
'
177
(:method ((x structure-object-template)) t)
'
178
(:method ((x t)) nil))
'
179
'
180
'
181
(defclass standard-object-template (type-template) ())
'
182
'
183
(defgeneric standard-object-template-p (x)
'
184
(:method ((x standard-object-template)) t)
'
185
(:method ((x t)) nil))
'
186
'
187
'
188
;;; Expression Templates.
'
189
'
190
(defclass subseq-template (expression-template) ())
'
191
'
192
(defgeneric subseq-template-p (x)
'
193
(:method ((x subseq-template)) t)
'
194
(:method ((x t)) nil))
'
195
'
196
'
197
'
198
(defclass element-template (expression-template) ())
'
199
'
200
(defgeneric element-template-p (x)
'
201
(:method ((x element-template)) t)
'
202
(:method ((x t)) nil))
'
203
'
204
'
205
(defclass elt-template (element-template) ())
'
206
'
207
(defgeneric elt-template-p (x)
'
208
(:method ((x elt-template)) t)
'
209
(:method ((x t)) nil))
'
210
'
211
'
212
(defclass aref-template (element-template) ())
'
213
'
214
(defgeneric aref-template-p (x)
'
215
(:method ((x aref-template)) t)
'
216
(:method ((x t)) nil))
'
217
'
218
'
219
(defclass nth-template (element-template) ())
'
220
'
221
(defgeneric nth-template-p (x)
'
222
(:method ((x nth-template)) t)
'
223
(:method ((x t)) nil))
'
224
'
225
'
226
(defclass nthcdr-template (element-template) ())
'
227
'
228
(defgeneric nthcdr-template-p (x)
'
229
(:method ((x nthcdr-template)) t)
'
230
(:method ((x t)) nil))
'
231
'
232
'
233
(defgeneric make-template (kind spec))
'
234
2008-07-13 mantoniotti
235
2004-11-17 mantoniotti
236
(defmethod make-template ((kind null) (spec symbol))
22:19:54 '
237
(assert (null spec) (spec) "MAKE-TEMPLATE called erroneously with ~S and ~S." kind spec)
'
238
(make-instance 'nil-template :spec spec))
'
239
'
240
(defmethod make-template ((kind symbol) (spec symbol))
'
241
(make-instance 'symbol-template :spec spec))
'
242
'
243
(defmethod make-template ((kind (eql 'symbol)) (spec cons))
'
244
(make-instance 'symbol-template :spec spec))
'
245
'
246
(defmethod make-template ((kind symbol) (spec cons))
'
247
(cond ((subtypep kind 'number)
'
248
(make-instance 'number-template :spec spec))
'
249
((subtypep kind 'structure-object)
'
250
(make-instance 'structure-object-template :spec spec))
'
251
((subtypep kind 'standard-object)
'
252
(make-instance 'standard-object-template :spec spec))
'
253
(t
'
254
(error 'unification-template-error
'
255
:format-control "Unknown template specifier ~S."
'
256
:format-arguments (list kind)))
'
257
))
'
258
'
259
(defmethod make-template ((kind cons) (spec cons))
'
260
(cond ((subtypep kind 'number)
'
261
(make-instance 'number-template :spec spec))
'
262
((subtypep kind 'string)
'
263
(make-instance 'string-template :spec spec))
'
264
((subtypep kind 'vector)
'
265
(make-instance 'vector-template :spec spec))
'
266
((subtypep kind 'array)
'
267
(make-instance 'array-template :spec spec))
'
268
(t
'
269
(error 'unification-template-error
'
270
:format-control "Unknown template specifier ~S."
'
271
:format-arguments (list kind)))
'
272
))
'
273
'
274
(defmethod make-template ((kind number) (spec number))
'
275
(assert (= kind spec))
'
276
(make-instance 'number-template :spec spec))
'
277
'
278
(defmethod make-template ((kind (eql 'sequence)) (spec cons))
'
279
(make-instance 'sequence-template :spec spec))
'
280
'
281
(defmethod make-template ((kind (eql 'list)) (spec cons))
'
282
(make-instance 'list-template :spec spec))
'
283
2009-04-15 mantoniotti
284
(defmethod make-template ((kind (eql 'lambda)) (spec cons))
10:18:59 '
285
(make-instance 'lambda-template :spec spec))
'
286
2004-11-17 mantoniotti
287
(defmethod make-template ((kind (eql 'vector)) (spec cons))
22:19:54 '
288
(make-instance 'vector-template :spec spec))
'
289
'
290
(defmethod make-template ((kind (eql 'string)) (spec cons))
'
291
(make-instance 'string-template :spec spec))
'
292
'
293
(defmethod make-template ((kind (eql 'array)) (spec cons))
'
294
(make-instance 'array-template :spec spec))
'
295
'
296
'
297
(defmethod make-template ((kind (eql 'subseq)) (spec cons))
'
298
(make-instance 'subseq-template :spec spec))
'
299
'
300
(defmethod make-template ((kind (eql 'elt)) (spec cons))
'
301
(make-instance 'elt-template :spec spec))
'
302
'
303
(defmethod make-template ((kind (eql 'aref)) (spec cons))
'
304
(make-instance 'aref-template :spec spec))
'
305
'
306
(defmethod make-template ((kind (eql 'nth)) (spec cons))
'
307
(make-instance 'nth-template :spec spec))
'
308
'
309
(defmethod make-template ((kind (eql 'nthcdr)) (spec cons))
'
310
(make-instance 'nthcdr-template :spec spec))
'
311
'
312
'
313
2008-07-13 mantoniotti
314
;;;;===========================================================================
13:10:48 '
315
;;;; Implementation.
2004-11-17 mantoniotti
316
22:19:54 '
317
;;; Symbol Templates.
'
318
;;; Specification is
'
319
;;;
'
320
;;; (symbol <symbol>)
'
321
'
322
(defun symbol-template-symbol (x)
'
323
(declare (type symbol-template x))
'
324
(assert (symbol-template-p x) (x) "Non symbol template ~S." x)
'
325
(let ((spec (template-spec x)))
'
326
(cond ((symbolp spec) spec)
'
327
((consp spec) (second spec)))))
'
328
'
329
'
330
;;; Number template
'
331
;;; Specification is
'
332
;;;
'
333
;;; (<number type> <number>)
'
334
;;; or
'
335
;;;
'
336
;;; <number>
'
337
'
338
(defun number-template-number (x)
'
339
(declare (type number-template x))
'
340
(assert (number-template-p x) (x) "Non number template ~S." x)
'
341
(let ((spec (template-spec x)))
'
342
(etypecase spec
'
343
(symbol spec)
'
344
(number spec)
'
345
(cons (second spec)))))
'
346
'
347
2009-12-17 mantoniotti
348
(defun number-template-numeric-type (x)
16:43:12 '
349
(declare (type number-template x))
'
350
(let ((n (number-template-number x)))
'
351
(if (numberp n)
'
352
(type-of n)
'
353
(first (template-spec x)))))
'
354
'
355
(defun number-template-numeric-class (x)
'
356
(declare (type number-template x))
'
357
(let ((n (number-template-number x)))
'
358
(if (numberp n)
'
359
(class-of n)
'
360
(find-class (first (template-spec x))))))
'
361
'
362
'
363
'
364
2004-11-17 mantoniotti
365
;;; Sequence Templates.
22:19:54 '
366
;;; Specification is
'
367
;;;
'
368
;;; (<sequence subtype> . <destructuring template lambda list>)
'
369
;;; or
'
370
;;; (subseq <from> <to> . <destructuring template lambda list>)
'
371
'
372
(defun sequence-template-lambda-list (x)
'
373
(declare (type sequence-template x))
'
374
(assert (sequence-template-p x) (x) "Non sequence template ~S." x)
'
375
(rest (template-spec x)))
'
376
'
377
'
378
;;; Vector Templates.
'
379
;;; Specification is
'
380
;;;
'
381
;;; (<vector type specifier> . <destructuring template lambda list>)
'
382
'
383
(defun vector-template-element-type (x)
'
384
(declare (type vector-template x))
'
385
(assert (vector-template-p x) (x) "Non vector template ~S." x)
'
386
(let ((spec (type-template-type-spec x)))
'
387
(if (consp spec)
'
388
(destructuring-bind (vector-kwd &optional (element-type '*) size)
'
389
spec
'
390
(declare (ignore vector-kwd size))
'
391
element-type)
'
392
'*)))
'
393
'
394
'
395
(defun vector-template-size (x)
'
396
(declare (type vector-template x))
'
397
(assert (vector-template-p x) (x) "Non vector template ~S." x)
'
398
(let ((spec (type-template-type-spec x)))
'
399
(if (consp spec)
'
400
(destructuring-bind (vector-kwd &optional element-type (size '*))
'
401
spec
'
402
(declare (ignore vector-kwd element-type))
'
403
size)
'
404
'*)))
'
405
'
406
'
407
;;; Array Templates.
'
408
;;; Specification is
'
409
;;;
'
410
;;; (array (['*' | <element type>] [<dimension spec>]) <shape template>)
'
411
;;; or
'
412
;;; (<array type specifier> <shape template>)
'
413
'
414
'
415
(defun array-template-shape-template (x)
'
416
(declare (type array-template x))
'
417
(assert (array-template-p x) (x) "Non array template ~S." x)
'
418
(let ((t-spec (template-spec x)))
'
419
(if (= 2 (list-length t-spec))
'
420
(second t-spec)
'
421
(third t-spec))))
'
422
'
423
'
424
(defun array-template-element-type (x)
'
425
(declare (type array-template x))
'
426
(assert (array-template-p x) (x) "Non array template ~S." x)
'
427
(let ((type-spec (type-template-type-spec x)))
'
428
(if (consp type-spec)
'
429
(destructuring-bind (array-kwd &optional (element-type '*) dimension-spec)
'
430
type-spec
'
431
(declare (ignore array-kwd dimension-spec))
'
432
element-type)
'
433
'*)))
'
434
'
435
'
436
(defun array-template-dimensions (x)
'
437
(declare (type array-template x))
'
438
(assert (array-template-p x) (x) "Non array template ~S." x)
'
439
(let ((type-spec (type-template-type-spec x)))
'
440
(if (consp type-spec)
'
441
(destructuring-bind (array-kwd &optional element-type (dimension-spec '*))
'
442
type-spec
'
443
(declare (ignore array-kwd element-type))
'
444
dimension-spec)
'
445
'*)))
'
446
'
447
'
448
'
449
;;; Structure and Standard Object Templates.
'
450
2009-12-17 mantoniotti
451
(defun structure-object-template-class (x)
16:43:12 '
452
(and (structure-object-template-p x)
'
453
(first (template-spec x))))
'
454
2004-11-17 mantoniotti
455
(defun structure-object-template-slots (x)
22:19:54 '
456
(and (structure-object-template-p x)
'
457
(rest (template-spec x))))
'
458
'
459
2009-12-17 mantoniotti
460
(defun standard-object-template-class (x)
16:43:12 '
461
(and (standard-object-template-p x)
'
462
(first (template-spec x))))
'
463
2004-11-17 mantoniotti
464
(defun standard-object-template-slots (x)
22:19:54 '
465
(and (standard-object-template-p x)
'
466
(rest (template-spec x))))
'
467
'
468
'
469
;;;---------------------------------------------------------------------------
'
470
;;; Expression Templates.
'
471
'
472
'
473
;;; AREF Templates.
'
474
'
475
(defun aref-template-indexes (x)
'
476
(declare (type aref-template x))
'
477
(assert (aref-template-p x) (x) "Non aref template ~S." x)
'
478
(let ((spec (template-spec x)))
'
479
(second spec)))
'
480
'
481
'
482
(defun aref-template-element (x)
'
483
(declare (type aref-template x))
'
484
(assert (aref-template-p x) (x) "Non array template ~S." x)
'
485
(let ((spec (template-spec x)))
'
486
(third spec)))
'
487
'
488
'
489
'
490
'
491
;;;===========================================================================
'
492
;;; Template variables.
'
493
;;; Let's walk down a template.
'
494
;;; Note that there is an asymmetry here: I admit some containers to have
'
495
;;; variables inside, but I do not search instances of a class for variables.
'
496
;;; This is an asymmetry that would be way too hard to fix without more
'
497
;;; introspective power (which is available in the MOP, but not standard.)
'
498
'
499
(defgeneric collect-template-vars (template))
'
500
'
501
(defmethod collect-template-vars ((template template))
'
502
(let ((spec (template-spec template)))
'
503
(nconc (collect-template-vars (car spec))
'
504
(collect-template-vars (cdr spec)))))
'
505
'
506
(defmethod collect-template-vars ((template symbol-template))
'
507
(let ((template (symbol-template-symbol template)))
'
508
(when (and (variablep template) (not (variable-any-p template)))
'
509
(list template))))
'
510
'
511
'
512
(defmethod collect-template-vars ((template number-template))
'
513
(let ((template (number-template-number template)))
'
514
(etypecase template
'
515
(number ())
2005-04-27 mantoniotti
516
(symbol (cond ((and (variablep template) (not (variable-any-p template)))
20:44:25 '
517
(list template))
2004-11-17 mantoniotti
518
((and (boundp template)
22:19:54 '
519
(numberp (symbol-value template)))
2005-04-27 mantoniotti
520
;; This handles cases like #T(number pi)
20:44:25 '
521
;; It may be too broad, but for the time being it seems ok.
'
522
nil)
2004-11-17 mantoniotti
523
(t
22:19:54 '
524
(error "Invalid number template ~S." template)))))))
'
525
'
526
'
527
(defmethod collect-template-vars ((template symbol))
'
528
(when (and (variablep template) (not (variable-any-p template)))
'
529
(list template)))
'
530
'
531
(defmethod collect-template-vars ((template null))
'
532
())
'
533
'
534
(defmethod collect-template-vars ((template cons))
'
535
(nconc (collect-template-vars (car template))
'
536
(collect-template-vars (cdr template))))
'
537
'
538
(defmethod collect-template-vars ((template string))
'
539
())
'
540
'
541
'
542
(defmethod collect-template-vars ((template vector))
'
543
(loop for e across template
'
544
nconc (collect-template-vars e)))
'
545
'
546
'
547
(defmethod collect-template-vars ((template array))
'
548
(loop for i below (array-total-size template)
'
549
nconc (collect-template-vars (row-major-aref template i))))
'
550
'
551
'
552
(defmethod collect-template-vars ((template t))
'
553
())
'
554
'
555
;;; end of file -- templates.lisp --