mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-25 05:51:55 -08:00
Code Issues Projects Releases Packages Wiki Activity

cmp: defun-cached: fix reset-cache and a declaration

Browse source 
reset-cache did cons a new array but did not assign it to the cache variable
so it was essentially a no-op. Also we bind cache to lexvar and then declare
that lexvar to preserve declaration semantics.
This commit is contained in:
Daniel Kochmański 2023-02-16 21:32:51 +01:00
parent e984568e7d
commit 81a671dea7
1 changed files with 8 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

14
src/cmp/cmputil.lsp
View file

@ -488,18 +488,20 @@ comparing circular objects."
((EQUAL EQUAL-WITH-CIRCULARITY) 'SI::HASH-EQUAL)
(t (setf test 'EQUALP) 'SI::HASH-EQUALP))))
`(progn
(eval-when (:compile-toplevel :load-toplevel :execute)
(defparameter ,cache-name (make-array 1024 :element-type t :adjustable nil)))
(defun ,reset-name ()
(defvar ,cache-name
(make-array 1024 :element-type t :adjustable nil))
(defun ,reset-name ()
(setf ,cache-name
(make-array 1024 :element-type t :adjustable nil)))
(defun ,name ,lambda-list
(flet ((,name ,lambda-list ,@body))
(let* ((hash (logand (,hash-function ,@lambda-list) 1023))
(elt (aref ,cache-name hash)))
(cache ,cache-name)
(elt (aref cache hash)))
(declare (type (integer 0 1023) hash)
(type (array t (*)) ,cache-name))
(type (array t (*)) cache))
(if (and elt ,@(loop for arg in lambda-list
collect `(,test (pop (ext:truly-the cons elt)) ,arg)))
collect `(,test (pop (ext:truly-the cons elt)) ,arg)))
(first (ext:truly-the cons elt))
(let ((output (,name ,@lambda-list)))
(setf (aref ,cache-name hash) (list ,@lambda-list output))