Sun Apr 12 16:43:33 CEST 2009 Tobias Rautenkranz <tobias@rautenkranz.ch>

* Support overloading by argument count for cxx: generic functions.

--- old-smoke/smoke.mbd 2014-09-28 09:39:59.000000000 +0200

+++ new-smoke/smoke.mbd 2014-09-28 09:39:59.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")

--- old-smoke/src/clos.lisp 2014-09-28 09:39:59.000000000 +0200

+++ new-smoke/src/clos.lisp 2014-09-28 09:39:59.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)))

--- old-smoke/src/cxx-method.lisp 1970-01-01 01:00:00.000000000 +0100

+++ new-smoke/src/cxx-method.lisp 2014-09-28 09:39:59.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))

--- old-smoke/src/method.lisp 2014-09-28 09:39:59.000000000 +0200

+++ new-smoke/src/method.lisp 2014-09-28 09:39:59.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)))

--- old-smoke/src/object-map.lisp 2014-09-28 09:39:59.000000000 +0200

+++ new-smoke/src/object-map.lisp 2014-09-28 09:39:59.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.

--- old-smoke/src/smoke.lisp 2014-09-28 09:39:59.000000000 +0200

+++ new-smoke/src/smoke.lisp 2014-09-28 09:39:59.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)