repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Fix overload resolution using types and test caching the overload resolution.
Annotate for file /src/using-type.lisp
2009-06-22 tobias
1
;;; NOTE -using-type is disabled for now, since it is not used.
12:18:08 '
2
2009-05-11 tobias
3
(in-package :smoke)
11:07:39 '
4
'
5
(defmacro with-object-as-object (object &body body)
2009-05-11 tobias
6
`(macrolet ((,(symbolicate object '.typep)
2009-05-11 tobias
7
(type)
11:07:39 '
8
`(typep ,',object ,type))
2009-05-11 tobias
9
(,(symbolicate object '.type-of) ()
2009-05-11 tobias
10
`(class-of ,',object))
11:07:39 '
11
(using-typep () nil)
'
12
(call-using-types (function-name &rest args)
'
13
`(,function-name ,@args))
'
14
(call-using-type (function-name &rest args)
'
15
`(,function-name ,@args)))
2009-09-01 tobias
16
,@body))
2009-05-11 tobias
17
11:07:39 '
18
(defun typep-using-type (object-type type)
'
19
"Returns true when OBJECT-TYPE is a subtype of TYPE,
2009-07-08 tobias
20
false when it is not."
2009-05-11 tobias
21
(declare (values (member t nil :maybe)))
11:07:39 '
22
(multiple-value-bind (subtype-p valid-p)
'
23
(subtypep object-type type)
'
24
(if subtype-p
'
25
t
'
26
(if valid-p
'
27
(multiple-value-bind (subtype-p valid-p)
'
28
(subtypep type object-type)
'
29
(if subtype-p
'
30
(throw 'unspecific-type (values object-type type))
'
31
(if valid-p
2009-07-08 tobias
32
(if (and (subtypep type 'integer)
14:56:52 '
33
(not (integer-types-disjunct-p object-type type)))
'
34
(throw 'unspecific-type (values object-type type))
'
35
nil)
2009-05-11 tobias
36
(throw 'unspecific-type (values object-type type)))))
11:07:39 '
37
(throw 'unspecific-type (values object-type))))))
'
38
'
39
(defmacro with-object-as-type (object-type &body body)
2009-05-11 tobias
40
`(macrolet ((,(symbolicate object-type '.typep)
2009-05-11 tobias
41
(type)
11:07:39 '
42
`(typep-using-type ,',object-type ,type))
2009-05-11 tobias
43
(,(symbolicate object-type '.type-of) ()
2009-05-11 tobias
44
(quote ,object-type))
11:07:39 '
45
(using-typep () t)
'
46
(call-using-types (function-name &rest args)
2009-05-11 tobias
47
`(,(symbolicate function-name '-using-types)
2009-05-11 tobias
48
,@args))
11:07:39 '
49
(call-using-type (function-name &rest args)
2009-05-11 tobias
50
`(,(symbolicate function-name '-using-type)
2009-05-11 tobias
51
,@args)))
11:07:39 '
52
,@body))
'
53
'
54
(defmacro defun+using-type (name object lambda-list &body body)
'
55
"Defines the functions NAME and NAME-using-type where the argument
'
56
OBJECT of LAMBDA-LIST is an object respective its type.
'
57
For OBJECT the functions OBJECT.typep and OBJECT.type-of can be used."
'
58
`(progn
'
59
(with-object-as-object ,object
'
60
(defun ,name ,lambda-list
'
61
,@body))
'
62
(with-object-as-type ,object
2009-05-11 tobias
63
(defun ,(symbolicate name '-using-type) ,lambda-list
2009-05-11 tobias
64
,@body))))
11:07:39 '
65
'
66
(defmacro defun+using-types (name lambda-list &body body)
'
67
`(progn (macrolet ((call-using-types (function-name &rest args)
'
68
`(,function-name ,@args))
'
69
(call-using-type (function-name &rest args)
'
70
`(,function-name ,@args))
'
71
(using-typep () nil)
'
72
(function-using-types (name)
'
73
`(function ,name)))
'
74
(defun ,name ,lambda-list
'
75
,@body))
'
76
(macrolet ((call-using-types (function-name &rest args)
2009-05-11 tobias
77
`(,(symbolicate function-name '-using-types)
2009-05-11 tobias
78
,@args))
11:07:39 '
79
(call-using-type (function-name &rest args)
2009-05-11 tobias
80
`(,(symbolicate function-name '-using-type)
2009-05-11 tobias
81
,@args))
11:07:39 '
82
(using-typep () t)
'
83
(function-using-types (name)
2009-05-11 tobias
84
`(function ,(symbolicate name '-using-types))))
12:30:33 '
85
(defun ,(symbolicate name '-using-types) ,lambda-list
2009-05-11 tobias
86
,@body))))
2009-07-08 tobias
87
14:56:52 '
88
(defun integer-types-disjunct-p (type1 type2)
'
89
;; FIXME implement this
'
90
(declare (ignore type1 type2))
'
91
nil)