darcs - smoke

1 (in-package :smoke)

3 (defclass cxx-generic-function (standard-generic-function)

4 ((gf-methods :initform nil :type list

5 :accessor gf-methods

6 :documentation "gf for different argument counts."))

7 (:metaclass closer-mop:funcallable-standard-class)

8 (:documentation "gf that can be overloaded by argument count."))

10 (defclass cxx-method-generic-function (standard-generic-function)

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."))

20 (defun make-lambda (argument-count)

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))))

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)))

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)

37 (= argument-count (argument-count gf)))

38 (gf-methods cxx-generic-function)))

40 (defun cxx-method-generic-function-name (cxx-generic-function argument-count)

41 (let ((*package* (find-package :cxx)))

42 (symbolicate (closer-mop:generic-function-name cxx-generic-function)

43 #\/ (write-to-string argument-count))))

45 (defun ensure-gf-by-argument-count (cxx-generic-function argument-count)

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)

52 (let* ((name (cxx-method-generic-function-name cxx-generic-function

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)

59 (push gf (gf-methods cxx-generic-function))

60 gf)))

62 (defun method-argument-count (method)

63 "Returns the number of arguments of METHOD."

64 (length (closer-mop:method-lambda-list method)))

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))))

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 ()

75 "The method ~A must not contain lambda list keywords." method))

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)))

80 (let ((generic-function (ensure-gf-by-argument-count

81 cxx-generic-function

82 (method-argument-count method))))

83 (add-method generic-function method)))

85 (defun unpush-method (method)

86 "Removes METHOD from its generic-function."

87 (let ((generic-function (closer-mop:method-generic-function method)))

88 (when generic-function

89 (remove-method generic-function method))))

90 ;(when (null (closer-mop:generic-function-methods generic-function))

91 ; TODO

93 (defmethod no-applicable-method ((gf cxx-method-generic-function) &rest args)

94 (apply #'no-applicable-method (cxx-generic-function gf) args))

96 #+sbcl

97 (defmethod closer-mop:compute-applicable-methods-using-classes ((gf cxx-generic-function) classes)

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

106 ;; on start up and the eval stuff is slower.

107 (if (null (gf-methods cxx-generic-function))

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

119 #+sbcl

120 (defmethod compute-applicable-methods ((gf cxx-generic-function) arguments)

121 ;; -using-classes only cares about the number of arguments;

122 ;; thus no the to actually pass the classes.

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)

148 (unpush-method method)

149 (update-method gf 'remove-method method))

150

151 #|

152 (defun cxx-dispatch-compiler-macro (cxx-generic-function)

153 "Returns a compiler-macro form for CXX-GENERIC-FUNCTION that

154 precomputes the dispatching for the argument count, if possible."

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 |#