Mon May 11 22:18:23 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>
* Make &rest lambda list for static methods only when necessary.
diff -rN -u old-smoke/src/method.lisp new-smoke/src/method.lisp
--- old-smoke/src/method.lisp 2014-09-30 10:27:17.000000000 +0200
+++ new-smoke/src/method.lisp 2014-09-30 10:27:18.000000000 +0200
@@ -1,4 +1,5 @@
(in-package :smoke)
+(declaim (optimize (debug 3)))
(defun constant-definition (method smoke)
"Returns an expression that defines a constant for the enum METHOD.
@@ -34,16 +35,21 @@
"."))
(name method)))))
-(defun static-method-definition (method)
+(defun static-method-definition (method &optional (argument-count -1))
"Returns an expression to define a function for the static METHOD.
The second return value is the expression to export the function."
(let* ((class (get-class method))
(method-name (name method))
(name (static-method-symbol method)))
(values
- `(defun ,name (&rest args)
+ `(defun ,name ,(if (< argument-count 0)
+ '(&rest args)
+ (make-lambda argument-count))
(call-using-args (find-class (quote ,(lispify (name class))))
- ,method-name args))
+ ,method-name
+ ,(if (< argument-count 0)
+ 'args
+ `(list ,@(make-lambda argument-count)))))
`(export (quote ,name)))))
(defun ensure-generic-methods (symbols-names)
@@ -116,13 +122,23 @@
(setf (gethash (lispify name "CXX") generics)
name))
(when (static-p method)
- (let ((function-symbol (static-method-symbol method)))
- (unless (nth-value 1 (gethash function-symbol function-symbols))
- (setf (gethash function-symbol function-symbols) t)
- (multiple-value-bind (def export) (static-method-definition method)
- (push def functions)
- (push export exports)))))))
+ (let* ((function-symbol (static-method-symbol method))
+ (methods (gethash function-symbol function-symbols)))
+ (setf (gethash function-symbol function-symbols)
+ (if methods (- (id method)) (id method)))))))
(eval smoke))
+ (loop for id being the hash-values of function-symbols do
+ (let ((method (make-instance 'smoke-method
+ :id (abs id)
+ :smoke (eval smoke))))
+ (multiple-value-bind (definition export)
+ (static-method-definition
+ method
+ (if (< 0 id)
+ (get-arguments-length method)
+ -1))
+ (push definition functions)
+ (push export exports))))
`(progn (check-recompile ,smoke)
,@functions
(eval-when (:load-toplevel :execute)
diff -rN -u old-smoke/src/overload-resolution.lisp new-smoke/src/overload-resolution.lisp
--- old-smoke/src/overload-resolution.lisp 2014-09-30 10:27:17.000000000 +0200
+++ new-smoke/src/overload-resolution.lisp 2014-09-30 10:27:18.000000000 +0200
@@ -80,9 +80,11 @@
(dolist (c (smoke-modules super-class))
(setf modules (adjoin c modules :key #'smoke)))))))
-(defun candidate-functions (name argument-count class2)
+
+(defun viable-functions (name argument-count class2)
"Returns a list of methods named NAME that take ARGUMENT-COUNT methods."
- (let (methods)
+ ;; 13.3.2
+ (let ((methods))
(dolist (class (smoke-modules class2))
(let ((index (binary-search-method-names
name (smoke class) 1
@@ -107,8 +109,6 @@
methods)))))))))
methods))
-
-
(defconstant +exact-match+ 0)
(defconstant +promotion+ 1)
(defconstant +conversion+ 2)
@@ -255,12 +255,12 @@
(not (typep class 'smoke-standard-class)))
(format t "ERROR TYPE~%")
(throw 'unspecific-type class))
- (let ((candidate-functions (candidate-functions name (length objects)
+ (let ((viable-functions (viable-functions name (length objects)
class))
(best-rank)
(best-method)
(conversions))
- (loop for method in candidate-functions do
+ (loop for method in viable-functions do
(multiple-value-bind (rank method-conversions)
(funcall get-sequence method objects)
(when (and rank (conversion< rank best-rank))
@@ -459,9 +459,9 @@
Candidates are:~{~T~A~%~}."
name object-or-class arguments
(mapcar #'signature
- (candidate-functions name
- (length arguments)
- (smoke-class-of object-or-class)))))
+ (viable-functions name
+ (length arguments)
+ (smoke-class-of object-or-class)))))
(if (static-p method)
(apply #'call-sequence method (null-pointer) sequence arguments)
(apply #'call-sequence method (cast object-or-class (get-class method))