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 /lambda-list-parsing.lisp
2004-11-17 mantoniotti
1
;;; -*- Mode: Lisp -*-
22:19:54 '
2
'
3
;;; lambda-list-parsing.lisp --
'
4
2011-04-02 mantoniotti
5
;;;; See file COPYING for copyright licensing information.
04:05:18 '
6
2004-11-17 mantoniotti
7
(in-package "UNIFY")
22:19:54 '
8
'
9
'
10
(declaim (inline type-is-t-p))
'
11
'
12
(defun type-is-t-p (type-spec)
'
13
(nth-value 0 (and (subtypep type-spec t) (subtypep t type-spec))))
'
14
'
15
'
16
(declaim (inline type-specifier-p))
'
17
'
18
(defun type-specifier-p (x)
'
19
(nth-value 0 (ignore-errors (subtypep x t))))
'
20
'
21
(defun normalize-lambda-list (lambda-list)
'
22
(mapcar (lambda (lambda-element)
'
23
(etypecase lambda-element
'
24
(symbol lambda-element)
'
25
(cons (first lambda-element))))
'
26
lambda-list))
'
27
'
28
'
29
(defstruct lambda-var-info
'
30
(name nil :read-only t)
'
31
(type t :read-only t)
'
32
)
'
33
'
34
(defstruct (optional-lambda-var-info (:include lambda-var-info))
'
35
(default-value nil :read-only t)
'
36
(name-for-supplied-indicator nil :read-only t)
'
37
)
'
38
'
39
(defstruct (aux-lambda-var-info (:include optional-lambda-var-info)))
'
40
'
41
(defstruct (key-lambda-var-info (:include optional-lambda-var-info))
'
42
(keyword-name nil :read-only t)
'
43
)
'
44
'
45
(defstruct (rest-lambda-var-info (:include lambda-var-info)
'
46
(:constructor make-rest-lambda-var-info (&key
'
47
name
'
48
(type 'list)
'
49
(element-type t))))
'
50
(element-type t :read-only t)
'
51
)
'
52
'
53
;;; The next function is really implementation-dependent, give the
2011-04-02 rbrown
54
;;; definition of LAMBDA-LIST-KEYWORDS.
2004-11-17 mantoniotti
55
2005-01-28 mantoniotti
56
2004-11-17 mantoniotti
57
(define-condition lambda-list-parsing-error (program-error)
22:19:54 '
58
((item :reader lambda-list-parsing-error-item
'
59
:initarg :item)
'
60
)
2005-01-28 mantoniotti
61
(:report (lambda (llpe stream)
19:30:35 '
62
(format stream "Error while parsing an extended lambda-list (at ~S.)"
'
63
(lambda-list-parsing-error-item llpe))))
2004-11-17 mantoniotti
64
)
22:19:54 '
65
2005-01-28 mantoniotti
66
2004-11-17 mantoniotti
67
(defun symbol-or-cons-p (x)
22:19:54 '
68
(or (symbolp x) (consp x)))
'
69
'
70
'
71
(defun parse-extended-ordinary-lambda-list (lambda-list
'
72
&key
'
73
(ordinary-variable-test #'symbolp)
'
74
(optional-variable-test #'symbol-or-cons-p)
'
75
(rest-variable-test #'symbolp)
'
76
(key-variable-test #'symbol-or-cons-p)
'
77
(aux-variable-test #'symbol-or-cons-p)
'
78
)
'
79
(let ((vars ())
'
80
(optionals ())
'
81
(keywords ())
'
82
(rest ())
'
83
(auxiliary ())
'
84
)
'
85
(labels ((parse-named-arguments (lambda-list &aux (head (first lambda-list)))
'
86
(cond ((null lambda-list) nil)
'
87
((and (symbolp head)
'
88
(member head lambda-list-keywords))
'
89
(case head
'
90
(&optional (parse-optional-arguments (rest lambda-list)))
'
91
(&key (parse-keyword-arguments (rest lambda-list)))
'
92
(&aux (parse-auxiliary-arguments (rest lambda-list)))
'
93
(&rest (parse-rest-arguments (rest lambda-list)))
'
94
(otherwise
2011-04-02 rbrown
95
(warn "Keyword ~A is implementation dependent.~@
2004-11-17 mantoniotti
96
The parsing may not work properly."
22:19:54 '
97
head)
'
98
(skip-until-next-lambda-list-keyword (rest lambda-list))
'
99
))
'
100
)
'
101
((funcall ordinary-variable-test head)
'
102
(push head vars)
'
103
(parse-named-arguments (rest lambda-list)))
'
104
(t (error 'lambda-list-parsing-error :item head))
'
105
))
'
106
'
107
(parse-optional-arguments (lambda-list &aux (head (first lambda-list)))
'
108
(cond ((null lambda-list) nil)
'
109
((and (symbolp head)
'
110
(member head lambda-list-keywords))
'
111
(case head
'
112
(&optional (error 'lambda-list-parsing-error :item head))
'
113
(&key (parse-keyword-arguments (rest lambda-list)))
'
114
(&aux (parse-auxiliary-arguments (rest lambda-list)))
'
115
(&rest (parse-rest-arguments (rest lambda-list)))
'
116
(otherwise
2011-04-02 rbrown
117
(warn "Keyword ~A is implementation dependent.~@
2004-11-17 mantoniotti
118
The parsing may not work properly."
22:19:54 '
119
head)
'
120
(skip-until-next-lambda-list-keyword (rest lambda-list))
'
121
))
'
122
)
'
123
((funcall optional-variable-test head)
'
124
(push head optionals)
'
125
(parse-optional-arguments (rest lambda-list)))
'
126
(t (error 'lambda-list-parsing-error :item head))
'
127
))
'
128
'
129
(parse-keyword-arguments (lambda-list &aux (head (first lambda-list)))
'
130
(cond ((null lambda-list) nil)
'
131
((and (symbolp head)
'
132
(member head lambda-list-keywords))
'
133
(case head
'
134
(&optional (error 'lambda-list-parsing-error :item head))
'
135
(&key (error 'lambda-list-parsing-error :item head))
'
136
(&aux (parse-auxiliary-arguments (rest lambda-list)))
'
137
(&rest (parse-rest-arguments (rest lambda-list)))
'
138
(&allow-other-keys
'
139
(unless (or (null (rest lambda-list))
'
140
(eql (cadr lambda-list) '&aux))
'
141
(error 'lambda-list-parsing-error :item head))
'
142
(skip-until-next-lambda-list-keyword (rest lambda-list)))
'
143
(otherwise
2011-04-02 rbrown
144
(warn "Keyword ~A is implementation dependent.~@
2004-11-17 mantoniotti
145
The parsing may not work properly."
22:19:54 '
146
head)
'
147
(skip-until-next-lambda-list-keyword (rest lambda-list))
'
148
))
'
149
)
'
150
((funcall key-variable-test head)
'
151
(push head keywords)
'
152
(parse-keyword-arguments (rest lambda-list)))
'
153
(t (error 'lambda-list-parsing-error :item head))
'
154
))
'
155
'
156
(parse-rest-arguments (lambda-list &aux (head (first lambda-list)))
'
157
(cond ((null lambda-list) nil)
'
158
((consp head)
'
159
(push head rest)
'
160
;; Error checking here.
'
161
(parse-rest-arguments (rest lambda-list)))
'
162
((and (symbolp head)
'
163
(member head lambda-list-keywords))
'
164
(case head
'
165
(&optional (error 'lambda-list-parsing-error :item head))
'
166
(&key (parse-keyword-arguments (rest lambda-list)))
'
167
(&aux (parse-auxiliary-arguments (rest lambda-list)))
'
168
(&rest (error 'lambda-list-parsing-error :item head))
'
169
(otherwise
2011-04-02 rbrown
170
(warn "Keyword ~A is implementation dependent.~@
2004-11-17 mantoniotti
171
The parsing may not work properly."
22:19:54 '
172
head)
'
173
(skip-until-next-lambda-list-keyword (rest lambda-list))
'
174
))
'
175
)
'
176
((funcall rest-variable-test head)
'
177
(push head rest)
'
178
(parse-rest-arguments (rest lambda-list)))
'
179
(t (error 'lambda-list-parsing-error :item head))
'
180
))
'
181
'
182
(parse-auxiliary-arguments (lambda-list &aux (head (first lambda-list)))
'
183
(cond ((null lambda-list) nil)
'
184
((and (symbolp head)
'
185
(member head lambda-list-keywords))
'
186
(case head
'
187
(&optional (error 'lambda-list-parsing-error :item head))
'
188
(&key (error 'lambda-list-parsing-error :item head))
'
189
(&aux (error 'lambda-list-parsing-error :item head))
'
190
(&rest (error 'lambda-list-parsing-error :item head))
'
191
(otherwise
2011-04-02 rbrown
192
(warn "Keyword ~A is implementation dependent.~@
2004-11-17 mantoniotti
193
The parsing may not work properly."
22:19:54 '
194
head)
'
195
(skip-until-next-lambda-list-keyword (rest lambda-list))
'
196
))
'
197
)
'
198
((funcall aux-variable-test head)
'
199
(push head auxiliary)
'
200
(parse-auxiliary-arguments (rest lambda-list)))
'
201
(t (error 'lambda-list-parsing-error :item head))
'
202
))
'
203
'
204
(skip-until-next-lambda-list-keyword (lambda-list
'
205
&aux (head (first lambda-list)))
'
206
(cond ((null lambda-list) nil)
'
207
((and (symbolp head)
'
208
(member head lambda-list-keywords))
'
209
(case head
'
210
(&optional (parse-optional-arguments (rest lambda-list)))
'
211
(&key (parse-keyword-arguments (rest lambda-list)))
'
212
(&aux (parse-auxiliary-arguments (rest lambda-list)))
'
213
(&rest (parse-rest-arguments (rest lambda-list)))
'
214
(otherwise
2011-04-02 rbrown
215
(warn "Keyword ~A is implementation dependent.~@
2004-11-17 mantoniotti
216
The parsing may not work properly."
22:19:54 '
217
head)
'
218
(skip-until-next-lambda-list-keyword (rest lambda-list))
'
219
))
'
220
)
'
221
((symbol-or-cons-p head)
'
222
(skip-until-next-lambda-list-keyword (rest lambda-list)))
'
223
))
'
224
)
'
225
(parse-named-arguments lambda-list)
'
226
(values (nreverse vars)
'
227
(nreverse optionals)
'
228
(nreverse keywords)
'
229
(nreverse rest)
'
230
(nreverse auxiliary))
'
231
)))
'
232
'
233
'
234
(defun parse-var-type-info (var)
'
235
(etypecase var
'
236
(symbol (make-lambda-var-info :name var))
'
237
(cons (make-lambda-var-info :name (first var) :type (second var)))))
'
238
'
239
'
240
(defun parse-optional-var-type-info (var)
'
241
(etypecase var
'
242
(symbol (make-optional-lambda-var-info :name var))
'
243
(cons (etypecase (first var)
'
244
(symbol (if (second var) ; special case (foo nil) and (foo)
'
245
(make-optional-lambda-var-info
'
246
:name (first var)
'
247
:type (or (and (constantp (second var)) (type-of (second var)))
'
248
t))
'
249
(make-optional-lambda-var-info :name (first var))))
'
250
(cons (make-optional-lambda-var-info
'
251
:name (caar var)
'
252
:type (cadar var)
'
253
:default-value (cadr var)))
'
254
))
'
255
))
'
256
'
257
'
258
(defun parse-auxiliary-var-type-info (var)
'
259
(parse-optional-var-type-info var))
'
260
'
261
(defun parse-rest-var-type-info (var) ; See the FUNCTION type ANSI spec for an explanation.
'
262
(etypecase var
'
263
(symbol (make-rest-lambda-var-info :name var))
'
264
(cons (make-rest-lambda-var-info :name (first var) :element-type (second var)))))
'
265
'
266
'
267
(defun parse-key-var-type-info (var)
'
268
(etypecase var
'
269
(symbol (make-key-lambda-var-info :name var))
'
270
(cons (destructuring-bind (var &optional (init-value nil init-value-supplied-p))
'
271
var
'
272
(let ((init-value-type
'
273
(if init-value-supplied-p
'
274
(or (and (constantp init-value) (type-of init-value))
'
275
t)
'
276
t))
'
277
)
'
278
(etypecase var
'
279
(symbol (make-key-lambda-var-info :name var
'
280
:type init-value-type
'
281
:default-value init-value))
2011-04-02 rbrown
282
2004-11-17 mantoniotti
283
(cons (destructuring-bind (kwd var)
22:19:54 '
284
var
'
285
(etypecase var
'
286
(symbol
'
287
(make-key-lambda-var-info :name var
'
288
:default-value init-value
'
289
:type init-value-type
'
290
:keyword-name kwd))
'
291
(cons
'
292
(make-key-lambda-var-info :name (first var)
'
293
:default-value init-value
'
294
:type (second var)
'
295
:keyword-name kwd))))
'
296
))
'
297
)))
'
298
))
'
299
'
300
'
301
;;; end of file -- lambda-list-parsing.lisp --