Work at SourceForge, help us to make it a better place! We have an immediate need for a Support Technician in our San Francisco or Denver office.

Close

[98a76d]: src / code / early-type.lisp Maximize Restore History

Download this file

early-type.lisp    517 lines (479 with data), 20.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
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
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.
(in-package "SB!KERNEL")
(!begin-collecting-cold-init-forms)
;;; Has the type system been properly initialized? (I.e. is it OK to
;;; use it?)
(defvar *type-system-initialized* #+sb-xc-host nil) ; (set in cold load)
;;;; representations of types
;;; A HAIRY-TYPE represents anything too weird to be described
;;; reasonably or to be useful, such as NOT, SATISFIES, unknown types,
;;; and unreasonably complicated types involving AND. We just remember
;;; the original type spec.
(defstruct (hairy-type (:include ctype
(class-info (type-class-or-lose 'hairy))
(enumerable t)
(might-contain-other-types-p t))
(:copier nil)
#!+cmu (:pure nil))
;; the Common Lisp type-specifier of the type we represent
(specifier nil :type t))
(!define-type-class hairy)
;;; An UNKNOWN-TYPE is a type not known to the type system (not yet
;;; defined). We make this distinction since we don't want to complain
;;; about types that are hairy but defined.
(defstruct (unknown-type (:include hairy-type)
(:copier nil)))
(defstruct (negation-type (:include ctype
(class-info (type-class-or-lose 'negation))
;; FIXME: is this right? It's
;; what they had before, anyway
(enumerable t)
(might-contain-other-types-p t))
(:copier nil)
#!+cmu (:pure nil))
(type (missing-arg) :type ctype))
(!define-type-class negation)
;;; ARGS-TYPE objects are used both to represent VALUES types and
;;; to represent FUNCTION types.
(defstruct (args-type (:include ctype)
(:constructor nil)
(:copier nil))
;; Lists of the type for each required and optional argument.
(required nil :type list)
(optional nil :type list)
;; The type for the rest arg. NIL if there is no &REST arg.
(rest nil :type (or ctype null))
;; true if &KEY arguments are specified
(keyp nil :type boolean)
;; list of KEY-INFO structures describing the &KEY arguments
(keywords nil :type list)
;; true if other &KEY arguments are allowed
(allowp nil :type boolean))
(defun canonicalize-args-type-args (required optional rest)
(when rest
(let ((last-distinct-optional (position rest optional
:from-end t
:test-not #'type=)))
(setf optional
(when last-distinct-optional
(subseq optional 0 (1+ last-distinct-optional))))))
(values required optional rest))
(defun args-types (lambda-list-like-thing)
(multiple-value-bind
(required optional restp rest keyp keys allowp auxp aux)
(parse-lambda-list-like-thing lambda-list-like-thing)
(declare (ignore aux))
(when auxp
(error "&AUX in a FUNCTION or VALUES type: ~S." lambda-list-like-thing))
(let ((required (mapcar #'single-value-specifier-type required))
(optional (mapcar #'single-value-specifier-type optional))
(rest (when restp (single-value-specifier-type rest)))
(keywords
(collect ((key-info))
(dolist (key keys)
(unless (proper-list-of-length-p key 2)
(error "Keyword type description is not a two-list: ~S." key))
(let ((kwd (first key)))
(when (find kwd (key-info) :key #'key-info-name)
(error "~@<repeated keyword ~S in lambda list: ~2I~_~S~:>"
kwd lambda-list-like-thing))
(key-info
(make-key-info
:name kwd
:type (single-value-specifier-type (second key))))))
(key-info))))
(multiple-value-bind (required optional rest)
(canonicalize-args-type-args required optional rest)
(values required optional rest keyp keywords allowp)))))
(defstruct (values-type
(:include args-type
(class-info (type-class-or-lose 'values)))
(:constructor %make-values-type)
(:copier nil)))
(defun make-values-type (&rest initargs
&key (args nil argsp) &allow-other-keys)
(if argsp
(if (eq args '*)
*wild-type*
(multiple-value-bind (required optional rest keyp keywords allowp)
(args-types args)
(if (and (null required)
(null optional)
(eq rest *universal-type*)
(not keyp))
*wild-type*
(%make-values-type :required required
:optional optional
:rest rest
:keyp keyp
:keywords keywords
:allowp allowp))))
(apply #'%make-values-type initargs)))
(!define-type-class values)
;;; (SPECIFIER-TYPE 'FUNCTION) and its subtypes
(defstruct (fun-type (:include args-type
(class-info (type-class-or-lose 'function)))
(:constructor %make-fun-type))
;; true if the arguments are unrestrictive, i.e. *
(wild-args nil :type boolean)
;; type describing the return values. This is a values type
;; when multiple values were specified for the return.
(returns (missing-arg) :type ctype))
(defun make-fun-type (&rest initargs
&key (args nil argsp) returns &allow-other-keys)
(if argsp
(if (eq args '*)
(if (eq returns *wild-type*)
(specifier-type 'function)
(%make-fun-type :wild-args t :returns returns))
(multiple-value-bind (required optional rest keyp keywords allowp)
(args-types args)
(if (and (null required)
(null optional)
(eq rest *universal-type*)
(not keyp))
(if (eq returns *wild-type*)
(specifier-type 'function)
(%make-fun-type :wild-args t :returns returns))
(%make-fun-type :required required
:optional optional
:rest rest
:keyp keyp
:keywords keywords
:allowp allowp
:returns returns))))
;; FIXME: are we really sure that we won't make something that
;; looks like a completely wild function here?
(apply #'%make-fun-type initargs)))
;;; The CONSTANT-TYPE structure represents a use of the CONSTANT-ARG
;;; "type specifier", which is only meaningful in function argument
;;; type specifiers used within the compiler. (It represents something
;;; that the compiler knows to be a constant.)
(defstruct (constant-type
(:include ctype
(class-info (type-class-or-lose 'constant)))
(:copier nil))
;; The type which the argument must be a constant instance of for this type
;; specifier to win.
(type (missing-arg) :type ctype))
;;; The NAMED-TYPE is used to represent *, T and NIL. These types must
;;; be super- or sub-types of all types, not just classes and * and
;;; NIL aren't classes anyway, so it wouldn't make much sense to make
;;; them built-in classes.
(defstruct (named-type (:include ctype
(class-info (type-class-or-lose 'named)))
(:copier nil))
(name nil :type symbol))
;;; a list of all the float "formats" (i.e. internal representations;
;;; nothing to do with #'FORMAT), in order of decreasing precision
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter *float-formats*
'(long-float double-float single-float short-float)))
;;; The type of a float format.
(deftype float-format () `(member ,@*float-formats*))
;;; A NUMERIC-TYPE represents any numeric type, including things
;;; such as FIXNUM.
(defstruct (numeric-type (:include ctype
(class-info (type-class-or-lose 'number)))
(:constructor %make-numeric-type)
(:copier nil))
;; the kind of numeric type we have, or NIL if not specified (just
;; NUMBER or COMPLEX)
;;
;; KLUDGE: A slot named CLASS for a non-CLASS value is bad.
;; Especially when a CLASS value *is* stored in another slot (called
;; CLASS-INFO:-). Perhaps this should be called CLASS-NAME? Also
;; weird that comment above says "Numeric-Type is used to represent
;; all numeric types" but this slot doesn't allow COMPLEX as an
;; option.. how does this fall into "not specified" NIL case above?
;; Perhaps someday we can switch to CLOS and make NUMERIC-TYPE
;; be an abstract base class and INTEGER-TYPE, RATIONAL-TYPE, and
;; whatnot be concrete subclasses..
(class nil :type (member integer rational float nil) :read-only t)
;; "format" for a float type (i.e. type specifier for a CPU
;; representation of floating point, e.g. 'SINGLE-FLOAT -- nothing
;; to do with #'FORMAT), or NIL if not specified or not a float.
;; Formats which don't exist in a given implementation don't appear
;; here.
(format nil :type (or float-format null) :read-only t)
;; Is this a complex numeric type? Null if unknown (only in NUMBER).
;;
;; FIXME: I'm bewildered by FOO-P names for things not intended to
;; interpreted as truth values. Perhaps rename this COMPLEXNESS?
(complexp :real :type (member :real :complex nil) :read-only t)
;; The upper and lower bounds on the value, or NIL if there is no
;; bound. If a list of a number, the bound is exclusive. Integer
;; types never have exclusive bounds, i.e. they may have them on
;; input, but they're canonicalized to inclusive bounds before we
;; store them here.
(low nil :type (or number cons null) :read-only t)
(high nil :type (or number cons null) :read-only t))
;;; Impose canonicalization rules for NUMERIC-TYPE. Note that in some
;;; cases, despite the name, we return *EMPTY-TYPE* instead of a
;;; NUMERIC-TYPE.
(defun make-numeric-type (&key class format (complexp :real) low high
enumerable)
;; if interval is empty
(if (and low
high
(if (or (consp low) (consp high)) ; if either bound is exclusive
(>= (type-bound-number low) (type-bound-number high))
(> low high)))
*empty-type*
(multiple-value-bind (canonical-low canonical-high)
(case class
(integer
;; INTEGER types always have their LOW and HIGH bounds
;; represented as inclusive, not exclusive values.
(values (if (consp low)
(1+ (type-bound-number low))
low)
(if (consp high)
(1- (type-bound-number high))
high)))
(t
;; no canonicalization necessary
(values low high)))
(when (and (eq class 'rational)
(integerp canonical-low)
(integerp canonical-high)
(= canonical-low canonical-high))
(setf class 'integer))
(%make-numeric-type :class class
:format format
:complexp complexp
:low canonical-low
:high canonical-high
:enumerable enumerable))))
(defun modified-numeric-type (base
&key
(class (numeric-type-class base))
(format (numeric-type-format base))
(complexp (numeric-type-complexp base))
(low (numeric-type-low base))
(high (numeric-type-high base))
(enumerable (numeric-type-enumerable base)))
(make-numeric-type :class class
:format format
:complexp complexp
:low low
:high high
:enumerable enumerable))
;;; An ARRAY-TYPE is used to represent any array type, including
;;; things such as SIMPLE-STRING.
(defstruct (array-type (:include ctype
(class-info (type-class-or-lose 'array)))
(:constructor %make-array-type)
(:copier nil))
;; the dimensions of the array, or * if unspecified. If a dimension
;; is unspecified, it is *.
(dimensions '* :type (or list (member *)))
;; Is this not a simple array type? (:MAYBE means that we don't know.)
(complexp :maybe :type (member t nil :maybe))
;; the element type as originally specified
(element-type (missing-arg) :type ctype)
;; the element type as it is specialized in this implementation
(specialized-element-type *wild-type* :type ctype))
(define-cached-synonym make-array-type)
;;; A MEMBER-TYPE represent a use of the MEMBER type specifier. We
;;; bother with this at this level because MEMBER types are fairly
;;; important and union and intersection are well defined.
(defstruct (member-type (:include ctype
(class-info (type-class-or-lose 'member))
(enumerable t))
(:copier nil)
(:constructor %make-member-type (members))
#-sb-xc-host (:pure nil))
;; the things in the set, with no duplications
(members nil :type list))
(defun make-member-type (&key members)
(declare (type list members))
;; make sure that we've removed duplicates
(aver (= (length members) (length (remove-duplicates members))))
;; if we have a pair of zeros (e.g. 0.0d0 and -0.0d0), then we can
;; canonicalize to (DOUBLE-FLOAT 0.0d0 0.0d0), because numeric
;; ranges are compared by arithmetic operators (while MEMBERship is
;; compared by EQL). -- CSR, 2003-04-23
(let ((singlep (subsetp '(-0.0f0 0.0f0) members))
(doublep (subsetp '(-0.0d0 0.0d0) members))
#!+long-float
(longp (subsetp '(-0.0l0 0.0l0) members)))
(if (or singlep doublep #!+long-float longp)
(let (union-types)
(when singlep
(push (ctype-of 0.0f0) union-types)
(setf members (set-difference members '(-0.0f0 0.0f0))))
(when doublep
(push (ctype-of 0.0d0) union-types)
(setf members (set-difference members '(-0.0d0 0.0d0))))
#!+long-float
(when longp
(push (ctype-of 0.0l0) union-types)
(setf members (set-difference members '(-0.0l0 0.0l0))))
(aver (not (null union-types)))
(make-union-type t
(if (null members)
union-types
(cons (%make-member-type members)
union-types))))
(%make-member-type members))))
;;; A COMPOUND-TYPE is a type defined out of a set of types, the
;;; common parent of UNION-TYPE and INTERSECTION-TYPE.
(defstruct (compound-type (:include ctype
(might-contain-other-types-p t))
(:constructor nil)
(:copier nil))
(types nil :type list :read-only t))
;;; A UNION-TYPE represents a use of the OR type specifier which we
;;; couldn't canonicalize to something simpler. Canonical form:
;;; 1. All possible pairwise simplifications (using the UNION2 type
;;; methods) have been performed. Thus e.g. there is never more
;;; than one MEMBER-TYPE component. FIXME: As of sbcl-0.6.11.13,
;;; this hadn't been fully implemented yet.
;;; 2. There are never any UNION-TYPE components.
(defstruct (union-type (:include compound-type
(class-info (type-class-or-lose 'union)))
(:constructor %make-union-type (enumerable types))
(:copier nil)))
(define-cached-synonym make-union-type)
;;; An INTERSECTION-TYPE represents a use of the AND type specifier
;;; which we couldn't canonicalize to something simpler. Canonical form:
;;; 1. All possible pairwise simplifications (using the INTERSECTION2
;;; type methods) have been performed. Thus e.g. there is never more
;;; than one MEMBER-TYPE component.
;;; 2. There are never any INTERSECTION-TYPE components: we've
;;; flattened everything into a single INTERSECTION-TYPE object.
;;; 3. There are never any UNION-TYPE components. Either we should
;;; use the distributive rule to rearrange things so that
;;; unions contain intersections and not vice versa, or we
;;; should just punt to using a HAIRY-TYPE.
(defstruct (intersection-type (:include compound-type
(class-info (type-class-or-lose
'intersection)))
(:constructor %make-intersection-type
(enumerable types))
(:copier nil)))
;;; Return TYPE converted to canonical form for a situation where the
;;; "type" '* (which SBCL still represents as a type even though ANSI
;;; CL defines it as a related but different kind of placeholder) is
;;; equivalent to type T.
(defun type-*-to-t (type)
(if (type= type *wild-type*)
*universal-type*
type))
;;; A CONS-TYPE is used to represent a CONS type.
(defstruct (cons-type (:include ctype (class-info (type-class-or-lose 'cons)))
(:constructor
;; ANSI says that for CAR and CDR subtype
;; specifiers '* is equivalent to T. In order
;; to avoid special cases in SUBTYPEP and
;; possibly elsewhere, we slam all CONS-TYPE
;; objects into canonical form w.r.t. this
;; equivalence at creation time.
%make-cons-type (car-raw-type
cdr-raw-type
&aux
(car-type (type-*-to-t car-raw-type))
(cdr-type (type-*-to-t cdr-raw-type))))
(:copier nil))
;; the CAR and CDR element types (to support ANSI (CONS FOO BAR) types)
;;
;; FIXME: Most or all other type structure slots could also be :READ-ONLY.
(car-type (missing-arg) :type ctype :read-only t)
(cdr-type (missing-arg) :type ctype :read-only t))
(defun make-cons-type (car-type cdr-type)
(if (or (eq car-type *empty-type*)
(eq cdr-type *empty-type*))
*empty-type*
(%make-cons-type car-type cdr-type)))
;;;; type utilities
;;; Return the type structure corresponding to a type specifier. We
;;; pick off structure types as a special case.
;;;
;;; Note: VALUES-SPECIFIER-TYPE-CACHE-CLEAR must be called whenever a
;;; type is defined (or redefined).
(defun-cached (values-specifier-type
:hash-function (lambda (x)
(logand (sxhash x) #x3FF))
:hash-bits 10
:init-wrapper !cold-init-forms)
((orig equal-but-no-car-recursion))
(let ((u (uncross orig)))
(or (info :type :builtin u)
(let ((spec (type-expand u)))
(cond
((and (not (eq spec u))
(info :type :builtin spec)))
((eq (info :type :kind spec) :instance)
(find-classoid spec))
((typep spec 'classoid)
;; There doesn't seem to be any way to translate
;; (TYPEP SPEC 'BUILT-IN-CLASS) into something which can be
;; executed on the host Common Lisp at cross-compilation time.
#+sb-xc-host (error
"stub: (TYPEP SPEC 'BUILT-IN-CLASS) on xc host")
(if (typep spec 'built-in-classoid)
(or (built-in-classoid-translation spec) spec)
spec))
(t
(let* (;; FIXME: This automatic promotion of FOO-style
;; specs to (FOO)-style specs violates the ANSI
;; standard. Unfortunately, we can't fix the
;; problem just by removing it, since then things
;; downstream should break. But at some point we
;; should fix this and the things downstream too.
(lspec (if (atom spec) (list spec) spec))
(fun (info :type :translator (car lspec))))
(cond (fun
(funcall fun lspec))
((or (and (consp spec) (symbolp (car spec)))
(symbolp spec))
(when (and *type-system-initialized*
(not (eq (info :type :kind spec)
:forthcoming-defclass-type)))
(signal 'parse-unknown-type :specifier spec))
;; (The RETURN-FROM here inhibits caching.)
(return-from values-specifier-type
(make-unknown-type :specifier spec)))
(t
(error "bad thing to be a type specifier: ~S"
spec))))))))))
;;; This is like VALUES-SPECIFIER-TYPE, except that we guarantee to
;;; never return a VALUES type.
(defun specifier-type (x)
(let ((res (values-specifier-type x)))
(when (values-type-p res)
(error "VALUES type illegal in this context:~% ~S" x))
res))
(defun single-value-specifier-type (x)
(let ((res (specifier-type x)))
(if (eq res *wild-type*)
*universal-type*
res)))
;;; Similar to MACROEXPAND, but expands DEFTYPEs. We don't bother
;;; returning a second value.
(defun type-expand (form)
(let ((def (cond ((symbolp form)
(info :type :expander form))
((and (consp form) (symbolp (car form)))
(info :type :expander (car form)))
(t nil))))
(if def
(type-expand (funcall def (if (consp form) form (list form))))
form)))
;;; Note that the type NAME has been (re)defined, updating the
;;; undefined warnings and VALUES-SPECIFIER-TYPE cache.
(defun %note-type-defined (name)
(declare (symbol name))
(note-name-defined name :type)
(when (boundp 'sb!kernel::*values-specifier-type-cache-vector*)
(values-specifier-type-cache-clear))
(values))
(!defun-from-collected-cold-init-forms !early-type-cold-init)