/[cmucl]/src/code/typedefs.lisp
ViewVC logotype

Contents of /src/code/typedefs.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (show annotations)
Tue Apr 20 17:57:45 2010 UTC (3 years, 11 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, release-20b-pre1, release-20b-pre2, sparc-tramp-assem-2010-07-19, GIT-CONVERSION, cross-sol-x86-merged, RELEASE_20b, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2010-05, snapshot-2010-07, snapshot-2010-06, snapshot-2010-08, cross-sol-x86-2010-12-20, cross-sparc-branch-base, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, sparc-tramp-assem-branch, cross-sol-x86-branch
Changes since 1.16: +5 -5 lines
Change uses of _"foo" to (intl:gettext "foo").  This is because slime
may get confused with source locations if the reader macros are
installed.
1 ;;; -*- Package: KERNEL; Log: C.Log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/typedefs.lisp,v 1.17 2010/04/20 17:57:45 rtoy Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; This file contains the definition of the CTYPE (Compiler TYPE) structure
13 ;;; and related macros used for manipulating it. This is sort of a mini object
14 ;;; system with rather odd dispatching rules. Other compile-time definitions
15 ;;; needed by multiple files are also here.
16 ;;;
17 ;;; Written by Rob MacLachlan
18 ;;;
19 (in-package "KERNEL")
20 (intl:textdomain "cmucl")
21
22 (export '(ctype typedef-init))
23
24 ;;; These are the Common Lisp defined type specifier symbols. These are the
25 ;;; things which can be used as declarations without requiring the use of TYPE.
26 (defconstant type-specifier-symbols
27 '(array atom bignum bit bit-vector character compiled-function
28 complex cons double-float extended-char fixnum float function
29 hash-table integer keyword list long-float nil null number package
30 pathname random-state ratio rational real readtable sequence
31 short-float simple-array simple-bit-vector simple-string simple-vector
32 single-float standard-char stream string base-char symbol t vector
33 #+double-double double-double-float))
34
35
36 ;;; Def-Type-Translator -- Interface
37 ;;;
38 ;;; Define the translation from a type-specifier to a type structure for
39 ;;; some particular type. Syntax is identical to DEFTYPE.
40 ;;;
41 (defmacro def-type-translator (name arglist &body body)
42 (check-type name symbol)
43 (let ((whole (gensym)))
44 (multiple-value-bind
45 (body local-decs)
46 (lisp::parse-defmacro arglist whole body name 'def-type-translator
47 :default-default ''*)
48 `(progn
49 (cold-load-init
50 (setf (info type translator ',name)
51 #'(lambda (,whole) ,@local-decs (block ,name ,body))))
52 ',name))))
53
54
55 ;;; Defvars for these come later, after we have enough stuff defined.
56 (declaim (special *wild-type* *universal-type* *empty-type*))
57
58
59 ;;;; Cold load hack magic.
60
61 (eval-when (compile load eval)
62
63 (defparameter cold-type-init-forms nil
64 "Forms that must happen before top level forms are run.")
65
66 (defmacro with-cold-load-init-forms ()
67 '(eval-when (compile eval)
68 (setq cold-type-init-forms nil)))
69
70 (defmacro cold-load-init (&rest forms)
71 (if (and (consp forms) (consp (car forms)) (eq (caar forms) 'eval-when))
72 (let ((when (cadar forms))
73 (eval-when-forms (cddar forms)))
74 (unless (= (length forms) 1)
75 (warn (intl:gettext "Can't cold-load-init other forms along with an eval-when.")))
76 (when (member 'load when)
77 (setf cold-type-init-forms
78 (nconc cold-type-init-forms (copy-list eval-when-forms))))
79 `(eval-when ,(remove 'load when)
80 ,@eval-when-forms))
81 (progn
82 (setf cold-type-init-forms
83 (nconc cold-type-init-forms (copy-list forms)))
84 nil)))
85
86 (defmacro emit-cold-load-defuns (prefix)
87 (let ((index 0))
88 (collect ((defuns)
89 (calls))
90 (loop
91 (unless cold-type-init-forms (return))
92 (let ((num-forms (min 10 (length cold-type-init-forms)))
93 (name (intern (format nil "~A-INIT-~D" prefix (incf index)))))
94 (defuns `(defun ,name ()
95 ,@(subseq cold-type-init-forms 0 num-forms)))
96 (setf cold-type-init-forms (nthcdr num-forms cold-type-init-forms))
97 (calls (list name))))
98 `(progn
99 ,@(defuns)
100 (defun ,(intern (format nil "~A-INIT" prefix)) ()
101 ,@(calls)
102 nil)))))
103
104 ); eval-when
105
106 ;; Use this definition if you are trying to use this interactivly.
107 #+nil
108 (defmacro cold-load-init (&rest forms)
109 `(progn ,@forms))
110
111
112 ;;;; Type classes:
113 ;;;
114 ;;; The TYPE-CLASS structure represents the "kind" of a type. It mainly
115 ;;; contains functions which are methods on that kind of type, but is also use
116 ;;; in EQ comparisons to determined if two types have the "same kind".
117
118 (defvar *type-classes*)
119 (cold-load-init
120 (unless (boundp '*type-classes*)
121 (setq *type-classes* (make-hash-table :test #'eq))))
122
123 ;;; TYPE-CLASS-OR-LOSE -- Interface
124 ;;;
125 (defun type-class-or-lose (name)
126 (or (gethash name *type-classes*)
127 (error (intl:gettext "~S is not a defined type class.") name)))
128
129 ;;; MUST-SUPPLY-THIS -- Interface
130 ;;;
131 (defun must-supply-this (&rest foo)
132 (error (intl:gettext "Missing type method for ~S") foo))
133
134
135 (defstruct (type-class
136 (:print-function
137 (lambda (s stream d)
138 (declare (ignore d))
139 (format stream "#<TYPE-CLASS ~S>" (type-class-name s)))))
140
141 ;;
142 ;; Name of this type class, used to resolve references at load time.
143 (name nil :type symbol)
144 ;;
145 ;; Dyadic type methods. If the classes of the two types are EQ, then we call
146 ;; the SIMPLE-xxx method. If the classes are not EQ, and either type's class
147 ;; has a COMPLEX-xxx method, then we call it.
148 ;;
149 ;; Although it is undefined which method will get precedence when both types
150 ;; have a complex method, the complex method can assume that the second arg
151 ;; always is in its class, and the first always is not. The arguments to
152 ;; commutative operations will be swapped if the first argument has a complex
153 ;; method.
154 ;;
155 ;; Since SUBTYPEP is not commutative, we have two complex methods. the ARG1
156 ;; method is only called when the first argument is in its class, and the
157 ;; ARG2 method is only called when called when the second type is. If either
158 ;; is specified, both must be.
159 (simple-subtypep #'must-supply-this :type function)
160 (complex-subtypep-arg1 nil :type (or function null))
161 (complex-subtypep-arg2 nil :type (or function null))
162 ;;
163 ;; SIMPLE-UNION combines two types of the same class into a single type of
164 ;; that class. If the result is a two-type union, then return NIL.
165 ;; VANILLA-UNION returns whichever argument is a supertype of the other, or
166 ;; NIL.
167 (simple-union #'hierarchical-union2 :type function)
168 (complex-union nil :type (or function null))
169 ;;
170 ;; The default intersection methods assume that if one type is a subtype of
171 ;; the other, then that type is the intersection.
172 (simple-intersection #'hierarchical-intersection2 :type function)
173 (complex-intersection nil :type (or function null))
174 ;;
175 (simple-= #'must-supply-this :type function)
176 (complex-= nil :type (or function null))
177 ;;
178 ;; Function which returns a Common Lisp type specifier representing this
179 ;; type.
180 (unparse #'must-supply-this :type function)
181
182 #|
183 Not used, and not really right. Probably we want a TYPE= alist for the
184 unary operations, since there are lots of interesting unary predicates that
185 aren't equivalent to an entire class
186 ;;
187 ;; Names of functions used for testing the type of objects in this type
188 ;; class. UNARY-PREDICATE takes just the object, whereas PREDICATE gets
189 ;; passed both the object and the CTYPE. Normally one or the other will be
190 ;; supplied for any type that can be passed to TYPEP; there is no point in
191 ;; supplying both.
192 (unary-typep nil :type (or symbol null))
193 (typep nil :type (or symbol null))
194 ;;
195 ;; Like TYPEP, UNARY-TYPEP except these functions coerce objects to this
196 ;; type.
197 (unary-coerce nil :type (or symbol null))
198 (coerce :type (or symbol null))
199 |#
200 )
201
202
203 (eval-when (compile load eval)
204
205 (defconstant type-class-function-slots
206 '((:simple-subtypep . type-class-simple-subtypep)
207 (:complex-subtypep-arg1 . type-class-complex-subtypep-arg1)
208 (:complex-subtypep-arg2 . type-class-complex-subtypep-arg2)
209 (:simple-union . type-class-simple-union)
210 (:complex-union . type-class-complex-union)
211 (:simple-intersection . type-class-simple-intersection)
212 (:complex-intersection . type-class-complex-intersection)
213 (:simple-= . type-class-simple-=)
214 (:complex-= . type-class-complex-=)
215 (:unparse . type-class-unparse)))
216
217 (defconstant type-class-symbol-slots
218 '((:unary-typep . type-class-unary-typep)
219 (:typep . type-class-typep)
220 (:unary-coerce . type-class-unary-coerce)
221 (:coerce . type-class-coerce)))
222
223
224 ;;; CLASS-FUNCTION-SLOT-OR-LOSE -- Interface
225 ;;;
226 (defun class-function-slot-or-lose (name)
227 (or (cdr (assoc name type-class-function-slots))
228 (error (intl:gettext "~S is not a defined type class method.") name)))
229
230 ); Eval-When (Compile Load Eval)
231
232
233 ;;; DEFINE-TYPE-METHOD -- Interface
234 ;;;
235 (defmacro define-type-method ((class method &rest more-methods)
236 lambda-list &body body)
237 "DEFINE-TYPE-METHOD (Class-Name Method-Name+) Lambda-List Form*"
238 (let ((name (symbolicate CLASS "-" method "-TYPE-METHOD")))
239 `(progn
240 (defun ,name ,lambda-list ,@body)
241 (cold-load-init
242 ,@(mapcar #'(lambda (method)
243 `(setf (,(class-function-slot-or-lose method)
244 (type-class-or-lose ',class))
245 #',name))
246 (cons method more-methods)))
247 (undefined-value))))
248
249
250 ;;; DEFINE-TYPE-CLASS -- Interface
251 ;;;
252 (defmacro define-type-class (name &optional inherits)
253 "DEFINE-TYPE-CLASS Name [Inherits]"
254 `(cold-load-init
255 ,(once-only ((n-class (if inherits
256 `(copy-type-class (type-class-or-lose ',inherits))
257 '(make-type-class))))
258 `(progn
259 (setf (type-class-name ,n-class) ',name)
260 (setf (gethash ',name *type-classes*) ,n-class)
261 (undefined-value)))))
262
263
264 ;;; INVOKE-TYPE-METHOD -- Interface
265 ;;;
266 ;;; Invoke a type method on TYPE1 and TYPE2. If the two types have the same
267 ;;; class, invoke the simple method. Otherwise, invoke any complex method. If
268 ;;; there isn't a distinct complex-arg1 method, then swap the arguments when
269 ;;; calling type1's method. If no applicable method, return DEFAULT.
270 ;;;
271 (defmacro invoke-type-method (simple complex-arg2 type1 type2 &key
272 (default '(values nil t))
273 complex-arg1)
274 (let ((simple (class-function-slot-or-lose simple))
275 (cslot1 (class-function-slot-or-lose (or complex-arg1 complex-arg2)))
276 (cslot2 (class-function-slot-or-lose complex-arg2)))
277 (once-only ((n-type1 type1)
278 (n-type2 type2))
279 (once-only ((class1 `(type-class-info ,n-type1))
280 (class2 `(type-class-info ,n-type2)))
281 `(if (eq ,class1 ,class2)
282 (funcall (,simple ,class1) ,n-type1 ,n-type2)
283 ,(once-only ((complex1 `(,cslot1 ,class1))
284 (complex2 `(,cslot2 ,class2)))
285 `(cond (,complex2 (funcall ,complex2 ,n-type1 ,n-type2))
286 (,complex1
287 ,(if complex-arg1
288 `(funcall ,complex1 ,n-type1 ,n-type2)
289 `(funcall ,complex1 ,n-type2 ,n-type1)))
290 (t ,default))))))))
291
292
293 ;;; The XXX-Type structures include the CTYPE structure for some slots that
294 ;;; apply to all types.
295 ;;;
296 (defstruct (ctype (:conc-name type-)
297 (:constructor make-type)
298 (:make-load-form-fun make-type-load-form)
299 (:pure t))
300 ;;
301 ;; The class of this type.
302 (class-info (required-argument) :type type-class)
303 ;;
304 ;; True if this type has a fixed number of members, and as such could
305 ;; possibly be completely specified in a MEMBER type. This is used by the
306 ;; MEMBER type methods.
307 (enumerable nil :type (member t nil) :read-only t))
308
309 ;;; %Print-Type -- Internal
310 ;;;
311 ;;; The print-function for all type structures.
312 ;;;
313 (defun %print-type (s stream d)
314 (declare (ignore d))
315 (format stream "#<~A ~S>" (type-of s) (type-specifier s)))
316
317 ;;; Make-Type-Load-Form -- Internal
318 ;;;
319 ;;; Just dump it as a specifier, and convert it back upon loading.
320 ;;;
321 (defun make-type-load-form (type)
322 `(specifier-type ',(type-specifier type)))
323
324
325 ;;;; Utilities:
326
327 ;;; ANY-TYPE-OP, EVERY-TYPE-OP -- Interface
328 ;;;
329 ;;; Like ANY and EVERY, except that we handle two-arg uncertain predicates.
330 ;;; If the result is uncertain, then we return Default from the block PUNT.
331 ;;; If LIST-FIRST is true, then the list element is the first arg, otherwise
332 ;;; the second.
333 ;;;
334 (defmacro any-type-op (op thing list &key (default '(values nil nil))
335 list-first)
336 (let ((n-this (gensym))
337 (n-thing (gensym))
338 (n-val (gensym))
339 (n-win (gensym))
340 (n-uncertain (gensym)))
341 `(let ((,n-thing ,thing)
342 (,n-uncertain nil))
343 (dolist (,n-this ,list
344 (if ,n-uncertain
345 (return-from PUNT ,default)
346 nil))
347 (multiple-value-bind (,n-val ,n-win)
348 ,(if list-first
349 `(,op ,n-this ,n-thing)
350 `(,op ,n-thing ,n-this))
351 (unless ,n-win (setq ,n-uncertain t))
352 (when ,n-val (return t)))))))
353 ;;;
354 (defmacro every-type-op (op thing list &key (default '(values nil nil))
355 list-first)
356 (let ((n-this (gensym))
357 (n-thing (gensym))
358 (n-val (gensym))
359 (n-win (gensym)))
360 `(let ((,n-thing ,thing))
361 (dolist (,n-this ,list t)
362 (multiple-value-bind (,n-val ,n-win)
363 ,(if list-first
364 `(,op ,n-this ,n-thing)
365 `(,op ,n-thing ,n-this))
366 (unless ,n-win (return-from PUNT ,default))
367 (unless ,n-val (return nil)))))))
368
369
370
371 ;;; VANILLA-INTERSECTION -- Interface
372 ;;;
373 ;;; Compute the intersection for types that intersect only when one is a
374 ;;; hierarchical subtype of the other.
375 ;;;
376 (defun vanilla-intersection (type1 type2)
377 (multiple-value-bind (stp1 win1)
378 (csubtypep type1 type2)
379 (multiple-value-bind (stp2 win2)
380 (csubtypep type2 type1)
381 (cond (stp1 (values type1 t))
382 (stp2 (values type2 t))
383 ((and win1 win2) (values *empty-type* t))
384 (t
385 (values type1 nil))))))
386
387
388 ;;; VANILLA-UNION -- Interface
389 ;;;
390 (defun vanilla-union (type1 type2)
391 (cond ((csubtypep type1 type2) type2)
392 ((csubtypep type2 type1) type1)
393 (t nil)))
394
395 (defun hierarchical-intersection2 (type1 type2)
396 (multiple-value-bind (subtypep1 win1) (csubtypep type1 type2)
397 (multiple-value-bind (subtypep2 win2) (csubtypep type2 type1)
398 (cond (subtypep1 type1)
399 (subtypep2 type2)
400 ((and win1 win2) *empty-type*)
401 (t nil)))))
402
403 (defun hierarchical-union2 (type1 type2)
404 (cond ((csubtypep type1 type2) type2)
405 ((csubtypep type2 type1) type1)
406 (t nil)))
407
408 ;;; TYPE-CACHE-HASH -- Interface
409 ;;;
410 ;;; EQ hash two things (types) down to 8 bits.
411 ;;;
412 (defmacro type-cache-hash (type1 type2)
413 `(the fixnum
414 (logand (the fixnum
415 (logxor (the fixnum
416 (ash (cache-hash-eq ,type1) -3))
417 (the fixnum (cache-hash-eq ,type2))))
418 #xFF)))
419
420
421 ;;;; Cold loading initializations.
422
423 (emit-cold-load-defuns "TYPEDEF")
424

  ViewVC Help
Powered by ViewVC 1.1.5