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