diff options
| -rw-r--r-- | Lisp/internal-utilities.lisp | 26 | ||||
| -rw-r--r-- | Lisp/method-invocation.lisp | 4 |
2 files changed, 29 insertions, 1 deletions
diff --git a/Lisp/internal-utilities.lisp b/Lisp/internal-utilities.lisp index 818c18b..4e9d481 100644 --- a/Lisp/internal-utilities.lisp +++ b/Lisp/internal-utilities.lisp @@ -75,3 +75,29 @@ (if (find-symbol "FOREIGN-FUNCALL-POINTER" '#:cffi) `(cffi:foreign-funcall-pointer ,pointer ,options ,@args) `(cffi:foreign-funcall (,pointer ,@options) ,@args)))) + + +;; Caching of function values. +(defmacro define-cached-function (name lambda-list hashing-form &body body) + "Define a function and cache its result in a hash table. The hash key +is computed according to HASHING-FORM. + +Note that HASHING-FORM is expected to return a freshly consed object +that can be garbage collected. It is not recommended to use an atom as +a HASHING-FORM if the value of the atom might itself be an interned atom +or any other value that might never be deleted by the garbage +collector." + (let ((hash-table (gensym)) + (value (gensym)) + (default-value (gensym)) + (hash-key (gensym))) + `(let ((,hash-table (tg:make-weak-hash-table :weakness :key + :test 'equal))) + (defun ,name ,lambda-list + (let* ((,hash-key ,hashing-form) + (,value (gethash ,hash-key ,hash-table ',default-value))) + (if (eq ',default-value ,value) + (values-list + (setf (gethash ,hash-key ,hash-table) + (multiple-value-list (progn ,@body)))) + (values-list ,value))))))) diff --git a/Lisp/method-invocation.lisp b/Lisp/method-invocation.lisp index 4c5abac..d851f63 100644 --- a/Lisp/method-invocation.lisp +++ b/Lisp/method-invocation.lisp @@ -275,7 +275,9 @@ Returns: *result* --- the return value of the method invocation. return-c-type))))))))))) -(defun retrieve-method-signature-info (class selector) +(define-cached-function retrieve-method-signature-info (class selector) + (cons (cffi:pointer-address (pointer-to class)) + (cffi:pointer-address (pointer-to selector))) (let* ((signature (primitive-invoke class :instance-method-signature-for-selector 'id |