Sun Apr 12 16:43:33 CEST 2009 Tobias Rautenkranz * Support overloading by argument count for cxx: generic functions. diff -rN -u old-smoke/smoke.mbd new-smoke/smoke.mbd --- old-smoke/smoke.mbd 2014-10-01 19:31:52.000000000 +0200 +++ new-smoke/smoke.mbd 2014-10-01 19:31:52.000000000 +0200 @@ -37,7 +37,8 @@ ("object-map" (:needs "objects")) ("class-map" (:needs "package")) ("bindings" (:needs "package")) - ("clos" (:needs "smoke-c" "objects" "object-map" "class-map" "bindings")) + ("cxx-method" (:needs "package")) + ("clos" (:needs "smoke-c" "cxx-method" "objects" "object-map" "class-map" "bindings")) ("method" (:needs "clos")) (:objects module (:needs "smoke-c" "utils") diff -rN -u old-smoke/src/clos.lisp new-smoke/src/clos.lisp --- old-smoke/src/clos.lisp 2014-10-01 19:31:52.000000000 +0200 +++ new-smoke/src/clos.lisp 2014-10-01 19:31:52.000000000 +0200 @@ -72,9 +72,6 @@ (append-char #\:) (go default))) - - - (define-string-transform cxx-to-lisp "Returns camelCase STRING in lisp-style." (begin @@ -210,7 +207,8 @@ (defun make-smoke-classes (smoke) "Construts a lisp class for each one in the Smoke module SMOKE." - (declare (optimize (speed 3))) + (declare (optimize (speed 3)) + (cffi:foreign-pointer smoke)) (add-id-class-map smoke) (map-classes #'(lambda (class) @@ -226,14 +224,9 @@ (export (lispify (name class))))) smoke)) -(defun generic-lambda-list (method) - "Returns the lisp lambda list for METHOD." - (if (static-p method) - '(class &rest args) - '(object &rest args))) - -(defclass smoke-gf (standard-generic-function) - ((cxx-name :reader name :initarg :cxx-name)) +(defclass smoke-gf (cxx-generic-function) + ((cxx-name :reader name :initarg :cxx-name + :type string)) (:metaclass closer-mop:funcallable-standard-class) (:documentation "Smoke generic function")) @@ -243,27 +236,32 @@ object (class-of object))) -;;; To speed up the startup (MAKE-SMOKE-METHODS) +;;; To speed up the startup ;;; ENSURE-METHOD is only called as needed. (defmethod no-applicable-method ((gf smoke-gf) &rest args) "Calls the smoke method." + (declare (optimize (speed 3))) (let ((method (find-method-using-args (smoke-class-of (first args)) (name gf) (rest args)))) (if (static-p method) (s-call method (null-pointer) (rest args)) (s-call method (cast (first args) (get-class method)) (rest args))))) -(defmethod add-method :after ((gf smoke-gf) method) +(defmethod add-method :after ((gf cxx-method-generic-function) method) "Adds a method which calls the smoke method, to make call-next-method work." (when (null (rest (closer-mop:generic-function-methods gf))) - (closer-mop:ensure-method gf - `(lambda (object &rest args) - (let ((method (find-method-using-args (smoke-class-of object) - (name ,gf) - args))) - (if (static-p method) - (s-call method (null-pointer) args) - (s-call method (cast object (get-class method)) args))))))) + (let ((lambda-list (closer-mop:method-lambda-list method))) + (closer-mop:ensure-method + gf + `(lambda ,lambda-list + (declare (optimize (speed 3))) + (let ((method (find-method-using-args (smoke-class-of ,(first lambda-list)) + (name ,(cxx-generic-function gf)) + (list ,@(rest lambda-list))))) + (if (static-p method) + (s-call method (null-pointer) (list ,@lambda-list)) + (s-call method (cast ,(first lambda-list) (get-class method)) + (list ,@(rest lambda-list)))))))))) (defcallback destructed :void ((binding :pointer) @@ -325,7 +323,7 @@ :id method :smoke (smoke-get-smoke binding)))) (let ((gf (symbol-function (lispify (name method) "CXX")))) - (if (null (closer-mop:generic-function-methods gf)) + (if (null (gf-methods gf)) (progn (when abstract (error "Abstract method ~S called." (name method))) diff -rN -u old-smoke/src/cxx-method.lisp new-smoke/src/cxx-method.lisp --- old-smoke/src/cxx-method.lisp 1970-01-01 01:00:00.000000000 +0100 +++ new-smoke/src/cxx-method.lisp 2014-10-01 19:31:52.000000000 +0200 @@ -0,0 +1,138 @@ +(in-package :smoke) + +(defclass cxx-method-generic-function (standard-generic-function) + ((generic-function :accessor cxx-generic-function + :initarg :cxx-generic-function + :type cxx-generic-function + :documentation "Contains the generic function.")) + (:metaclass closer-mop:funcallable-standard-class) + (:documentation "Generic function of a specify argument count.")) + +(defclass cxx-generic-function (standard-generic-function) + ((gf-methods :initform nil + :accessor gf-methods + :type list + :documentation "Generic functions for different argument counts.")) + (:metaclass closer-mop:funcallable-standard-class) + (:documentation + "A generic function that can be overloaded by argument count.")) + +(defun make-lambda (argument-count) + "Returns a lambda expression for ARGUMENT-COUNT arguments." + (declare ((integer 0) argument-count)) + (loop for i from 0 below argument-count + collect (intern (format nil "A~A" i)))) + +(defun argument-count (generic-function) + "Returns the number of arguments to GENERIC-FUNCTION." + (length (closer-mop:generic-function-lambda-list generic-function))) + +(defun find-generic-function-by-argument-count (cxx-generic-function argument-count) + "Returns the generic function of CXX-GENERIC-FUNCTION that takes +ARGUMENT-COUNT arguments, or false when no such function exists." + (declare (cxx-generic-function cxx-generic-function) + ((integer 0) argument-count) + (values (or cxx-method-generic-function null))) + (find-if #'(lambda (gf) + (= argument-count + (argument-count gf))) + (gf-methods cxx-generic-function))) + +(defun ensure-gf-by-argument-count (cxx-generic-function argument-count) + "Returns the generic-function of CXX-GENERIC-FUNCTION that takes +ARGUMENT-COUNT arguments. When none exists, one is created." + (declare (cxx-generic-function cxx-generic-function) + ((integer 0) argument-count)) + (or (find-generic-function-by-argument-count cxx-generic-function + argument-count) + (let ((gf (make-instance 'cxx-method-generic-function + :cxx-generic-function cxx-generic-function + :lambda-list (make-lambda argument-count)))) + (push gf (gf-methods cxx-generic-function)) + gf))) + +(defun method-argument-count (method) + "Returns the number of arguments of METHOD." + (length (closer-mop:method-lambda-list method))) + +(defun lambda-list-keywords-p (lambda-list) + "Returns true when LAMBDA-LIST contains a lambda list keyword +and false otherwise." + (not (null (intersection lambda-list-keywords lambda-list)))) + +(defun check-cxx-method-argument-list (method) + "Signals an error when METHOD contains lambda list keywords." + (assert (not (lambda-list-keywords-p (closer-mop:method-lambda-list method))) + () + "The method ~A must not contatin lambda list keywords." method)) + +(defun push-method (method cxx-generic-function) + "Adds METHOD to a cxx-method-generic-function of CXX-GENERIC-FUNCTION." + (declare (optimize (speed 3))) + (let ((generic-function (ensure-gf-by-argument-count cxx-generic-function + (method-argument-count method)))) + (add-method generic-function method))) + +(defun unpush-method (method cxx-generic-function) + "Removes METHOD from its generic-function." + (let ((generic-function (closer-mop:method-generic-function method))) + (when generic-function + (remove-method (closer-mop:method-generic-function) method)))) + ;(when (null (closer-mop:generic-function-methods generic-function)) + ; TODO + +(defmethod no-applicable-method ((gf cxx-method-generic-function) &rest args) + (apply #'no-applicable-method (cxx-generic-function gf) args)) + +(defmethod closer-mop:compute-applicable-methods-using-classes ((gf cxx-generic-function) classes) + (let ((gf2 (find-generic-function-by-argument-count gf (length classes)))) + (if gf2 + (values (list gf2) t) + (values nil t)))) + +(defmethod closer-mop:compute-discriminating-function ((cxx-generic-function cxx-generic-function)) + (declare (optimize (speed 3))) + ;; Special case no methods, since it will apply to all cxx generic functions + ;; on startup and the eval stuff is slower. + (if (null (gf-methods cxx-generic-function)) + #'(lambda (&rest args) + (apply #'no-applicable-method cxx-generic-function args)) + (eval + `#'(lambda (&rest args) + (case (length args) + ,@(loop for gf in (gf-methods cxx-generic-function) + collect `(,(argument-count gf) + (apply ,gf args))) + (t (apply #'no-applicable-method ,cxx-generic-function args))))))) + + +(defmethod compute-applicable-methods ((gf cxx-generic-function) arguments) + ;; -using-classes only cares abount the number of arguments; + ;; thus no the to actually pass the classes. + (closer-mop:compute-applicable-methods-using-classes gf arguments)) + +(defun update-method (generic-function action method) + "Updates GENERIC-FUNCTION when METHOD has been added or removed; +and updates the dependents." + (declare (generic-function generic-function) + ((member add-method remove-method) action) + (standard-method method) + (optimize (speed 3))) + (closer-mop:set-funcallable-instance-function + generic-function + (closer-mop:compute-discriminating-function generic-function)) + (closer-mop:map-dependents + (class-of generic-function) + #'(lambda (dependent) + (closer-mop:update-dependent (class-of generic-function) + dependent + action method)))) + +(defmethod add-method ((gf cxx-generic-function) method) + (declare (optimize (speed 3))) + (push-method method gf) + (update-method gf 'add-method method)) + +(defmethod remove-method ((gf cxx-generic-function) method) + (unpush-method method gf) + (update-method gf 'remove-method method)) diff -rN -u old-smoke/src/method.lisp new-smoke/src/method.lisp --- old-smoke/src/method.lisp 2014-10-01 19:31:52.000000000 +0200 +++ new-smoke/src/method.lisp 2014-10-01 19:31:52.000000000 +0200 @@ -76,12 +76,13 @@ (defun ensure-generic-methods (symbols-names) "Ensures the generic functions for SYMBOLS-NAMES." + (declare (list symbols-names) + (optimize (speed 3))) (dolist (symbol-name symbols-names) (ensure-generic-function (first symbol-name) - :cxx-name (rest symbol-name) - :generic-function-class 'smoke-gf - :lambda-list '(object &rest args)) - + :cxx-name (rest symbol-name) + :generic-function-class 'smoke-gf + :lambda-list '(object &rest args)) (export (first symbol-name) :CXX))) (defmacro check-recompile (smoke) @@ -133,10 +134,9 @@ (eval smoke)) `(progn (check-recompile ,smoke) ,@functions - (eval-when (:load-toplevel) + (eval-when (:load-toplevel :execute) (ensure-generic-methods ',(hash-table-key-values generics)) - (make-smoke-classes ,smoke) - ) + (make-smoke-classes ,smoke)) ,@constants ,@exports))) diff -rN -u old-smoke/src/object-map.lisp new-smoke/src/object-map.lisp --- old-smoke/src/object-map.lisp 2014-10-01 19:31:52.000000000 +0200 +++ new-smoke/src/object-map.lisp 2014-10-01 19:31:52.000000000 +0200 @@ -4,7 +4,7 @@ #-cmucl (make-weak-hash-table :weakness :value) #+cmucl (make-hash-table :weak-p :value) - "Maps eisp object to Smoke C++ object of a class.") + "Maps a lisp object to Smoke C++ object.") ;; FIXME This probably does not scale well. A per thread object-map ;; or at least a read-write lock should be used. diff -rN -u old-smoke/src/smoke.lisp new-smoke/src/smoke.lisp --- old-smoke/src/smoke.lisp 2014-10-01 19:31:52.000000000 +0200 +++ new-smoke/src/smoke.lisp 2014-10-01 19:31:52.000000000 +0200 @@ -69,8 +69,8 @@ Calls the destrutor and frees the memory." (let ((method-name (concatenate 'string "~" (name class)))) (s-call - (make-smoke-method class method-name) - pointer)) + (make-smoke-method class method-name) + pointer)) (setf pointer (null-pointer))) (defun delete-object (object)