repos
/
smoke
/ annotate_shade
summary
|
shortlog
|
log
|
tree
|
commit
|
commitdiff
|
headdiff
|
annotate
|
headblob
|
headfilediff
|
filehistory
normal
|
plain
|
shade
|
zebra
Cleanup C++ to Lisp translation
Annotate for file src/cxx-method.lisp
2009-04-12 tobias
1
(in-package :smoke)
14:43:33 '
2
'
3
(defclass cxx-generic-function (standard-generic-function)
2009-08-02 tobias
4
((gf-methods :initform nil :type list
2009-04-12 tobias
5
:accessor gf-methods
2009-08-02 tobias
6
:documentation "gf for different argument counts."))
2009-04-12 tobias
7
(:metaclass closer-mop:funcallable-standard-class)
2009-08-02 tobias
8
(:documentation "gf that can be overloaded by argument count."))
2009-04-12 tobias
9
2009-05-19 tobias
10
(defclass cxx-method-generic-function (standard-generic-function)
11:09:12 '
11
((generic-function :accessor cxx-generic-function
'
12
:initarg :cxx-generic-function
'
13
:type cxx-generic-function
'
14
:documentation "Contains the generic function."))
'
15
(:metaclass closer-mop:funcallable-standard-class)
'
16
(:documentation "Generic function of a specify argument count."))
'
17
'
18
'
19
2009-04-12 tobias
20
(defun make-lambda (argument-count)
14:43:33 '
21
"Returns a lambda expression for ARGUMENT-COUNT arguments."
'
22
(declare ((integer 0) argument-count))
'
23
(loop for i from 0 below argument-count
'
24
collect (intern (format nil "A~A" i))))
'
25
'
26
(defun argument-count (generic-function)
'
27
"Returns the number of arguments to GENERIC-FUNCTION."
'
28
(length (closer-mop:generic-function-lambda-list generic-function)))
'
29
'
30
(defun find-generic-function-by-argument-count (cxx-generic-function argument-count)
'
31
"Returns the generic function of CXX-GENERIC-FUNCTION that takes
'
32
ARGUMENT-COUNT arguments, or false when no such function exists."
'
33
(declare (cxx-generic-function cxx-generic-function)
'
34
((integer 0) argument-count)
'
35
(values (or cxx-method-generic-function null)))
'
36
(find-if #'(lambda (gf)
2009-08-02 tobias
37
(= argument-count (argument-count gf)))
2009-04-12 tobias
38
(gf-methods cxx-generic-function)))
14:43:33 '
39
2009-05-11 tobias
40
(defun cxx-method-generic-function-name (cxx-generic-function argument-count)
11:07:39 '
41
(let ((*package* (find-package :cxx)))
2009-05-11 tobias
42
(symbolicate (closer-mop:generic-function-name cxx-generic-function)
12:30:33 '
43
#\/ (write-to-string argument-count))))
2009-05-11 tobias
44
2009-04-12 tobias
45
(defun ensure-gf-by-argument-count (cxx-generic-function argument-count)
14:43:33 '
46
"Returns the generic-function of CXX-GENERIC-FUNCTION that takes
'
47
ARGUMENT-COUNT arguments. When none exists, one is created."
'
48
(declare (cxx-generic-function cxx-generic-function)
'
49
((integer 0) argument-count))
'
50
(or (find-generic-function-by-argument-count cxx-generic-function
'
51
argument-count)
2009-05-11 tobias
52
(let* ((name (cxx-method-generic-function-name cxx-generic-function
11:07:39 '
53
argument-count))
'
54
(gf (make-instance 'cxx-method-generic-function
'
55
:name name
'
56
:cxx-generic-function cxx-generic-function
'
57
:lambda-list (make-lambda argument-count))))
'
58
(setf (fdefinition name) gf)
2009-04-12 tobias
59
(push gf (gf-methods cxx-generic-function))
14:43:33 '
60
gf)))
'
61
'
62
(defun method-argument-count (method)
'
63
"Returns the number of arguments of METHOD."
'
64
(length (closer-mop:method-lambda-list method)))
'
65
'
66
(defun lambda-list-keywords-p (lambda-list)
'
67
"Returns true when LAMBDA-LIST contains a lambda list keyword
'
68
and false otherwise."
'
69
(not (null (intersection lambda-list-keywords lambda-list))))
'
70
'
71
(defun check-cxx-method-argument-list (method)
'
72
"Signals an error when METHOD contains lambda list keywords."
'
73
(assert (not (lambda-list-keywords-p (closer-mop:method-lambda-list method)))
'
74
()
2009-07-01 tobias
75
"The method ~A must not contain lambda list keywords." method))
2009-04-12 tobias
76
14:43:33 '
77
(defun push-method (method cxx-generic-function)
'
78
"Adds METHOD to a cxx-method-generic-function of CXX-GENERIC-FUNCTION."
'
79
(declare (optimize (speed 3)))
2009-08-02 tobias
80
(let ((generic-function (ensure-gf-by-argument-count
10:12:41 '
81
cxx-generic-function
'
82
(method-argument-count method))))
2009-04-12 tobias
83
(add-method generic-function method)))
14:43:33 '
84
2009-05-11 tobias
85
(defun unpush-method (method)
2009-04-12 tobias
86
"Removes METHOD from its generic-function."
14:43:33 '
87
(let ((generic-function (closer-mop:method-generic-function method)))
'
88
(when generic-function
2009-05-14 tobias
89
(remove-method generic-function method))))
2009-04-12 tobias
90
;(when (null (closer-mop:generic-function-methods generic-function))
14:43:33 '
91
; TODO
'
92
'
93
(defmethod no-applicable-method ((gf cxx-method-generic-function) &rest args)
'
94
(apply #'no-applicable-method (cxx-generic-function gf) args))
'
95
2009-05-12 tobias
96
#+sbcl
2009-04-12 tobias
97
(defmethod closer-mop:compute-applicable-methods-using-classes ((gf cxx-generic-function) classes)
14:43:33 '
98
(let ((gf2 (find-generic-function-by-argument-count gf (length classes))))
'
99
(if gf2
'
100
(values (list gf2) t)
'
101
(values nil t))))
'
102
'
103
(defmethod closer-mop:compute-discriminating-function ((cxx-generic-function cxx-generic-function))
'
104
(declare (optimize (speed 3)))
'
105
;; Special case no methods, since it will apply to all cxx generic functions
2009-07-01 tobias
106
;; on start up and the eval stuff is slower.
2009-04-12 tobias
107
(if (null (gf-methods cxx-generic-function))
14:43:33 '
108
#'(lambda (&rest args)
'
109
(apply #'no-applicable-method cxx-generic-function args))
'
110
(eval
'
111
`#'(lambda (&rest args)
'
112
(case (length args)
'
113
,@(loop for gf in (gf-methods cxx-generic-function)
'
114
collect `(,(argument-count gf)
'
115
(apply ,gf args)))
'
116
(t (apply #'no-applicable-method ,cxx-generic-function args)))))))
'
117
'
118
2009-05-12 tobias
119
#+sbcl
2009-04-12 tobias
120
(defmethod compute-applicable-methods ((gf cxx-generic-function) arguments)
2009-07-01 tobias
121
;; -using-classes only cares about the number of arguments;
2009-04-12 tobias
122
;; thus no the to actually pass the classes.
14:43:33 '
123
(closer-mop:compute-applicable-methods-using-classes gf arguments))
'
124
'
125
(defun update-method (generic-function action method)
'
126
"Updates GENERIC-FUNCTION when METHOD has been added or removed;
'
127
and updates the dependents."
'
128
(declare (generic-function generic-function)
'
129
((member add-method remove-method) action)
'
130
(standard-method method)
'
131
(optimize (speed 3)))
'
132
(closer-mop:set-funcallable-instance-function
'
133
generic-function
'
134
(closer-mop:compute-discriminating-function generic-function))
'
135
(closer-mop:map-dependents
'
136
(class-of generic-function)
'
137
#'(lambda (dependent)
'
138
(closer-mop:update-dependent (class-of generic-function)
'
139
dependent
'
140
action method))))
'
141
'
142
(defmethod add-method ((gf cxx-generic-function) method)
'
143
(declare (optimize (speed 3)))
'
144
(push-method method gf)
'
145
(update-method gf 'add-method method))
'
146
'
147
(defmethod remove-method ((gf cxx-generic-function) method)
2009-05-11 tobias
148
(unpush-method method)
2009-04-12 tobias
149
(update-method gf 'remove-method method))
2009-05-11 tobias
150
11:07:39 '
151
#|
'
152
(defun cxx-dispatch-compiler-macro (cxx-generic-function)
2009-07-01 tobias
153
"Returns a compiler-macro form for CXX-GENERIC-FUNCTION that
2009-05-11 tobias
154
precomputes the dispatching for the argument count, if possible."
11:07:39 '
155
;; FIXME only applies when a defmethod with the right argument count
'
156
;; has been defined, which is almost never.
'
157
`(define-compiler-macro ,(closer-mop:generic-function-name cxx-generic-function)
'
158
(&whole form object &rest args)
'
159
(let ((name (cxx-method-generic-function-name (fdefinition (first form))
'
160
(1+ (length args)))))
'
161
(if (fboundp name)
'
162
`(,name ,object ,@args)
'
163
form))))
'
164
'
165
(defmethod initialize-instance :after ((gf cxx-generic-function) &key &allow-other-keys)
'
166
(eval (cxx-dispatch-compiler-macro gf)))
'
167
|#