mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-20 11:32:35 -08:00
Code Issues Projects Releases Packages Wiki Activity

cmp: fix caching of type specifiers

Browse source 
We cannot compare with (equal) here because subtype relations can
differ for member and eql types even if the type specifiers are the
same under equal.
This commit is contained in:
Marius Gerbershagen 2023-08-23 20:39:03 +02:00 • committed by Daniel Kochmański
parent b65b7d3825
commit 3f03a0c686
2 changed files with 25 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

12
src/cmp/cmptype-arith.lsp
View file

@ -79,7 +79,7 @@
(defun trivial-type-p (type)
(subtypep T type))
(defun-equal-cached type-and (t1 t2)
(defun-cached type-and (t1 t2) type-specifier=
;; FIXME! Should we allow "*" as type name???
(when (or (eq t1 t2) (eq t2 '*))
(return-from type-and t1))
@ -128,7 +128,7 @@
(let ((l (1- (length type))))
(values l l)))))
(defun-equal-cached values-type-primary-type (type)
(defun-cached values-type-primary-type (type) type-specifier=
;; Extract the type of the first value returned by this form. We are
;; pragmatic and thus (VALUES) => NULL [CHECKME!]
(let (aux)
@ -144,7 +144,7 @@
(t
aux))))
(defun-equal-cached values-type-to-n-types (type length)
(defun-cached values-type-to-n-types (type length) type-specifier=
(when (plusp length)
(do-values-type-to-n-types type length)))
@ -195,7 +195,7 @@
(return (values (nreverse required) (nreverse optional)
rest a-o-k)))))
(defun-equal-cached values-type-or (t1 t2)
(defun-cached values-type-or (t1 t2) type-specifier=
(when (or (eq t2 'T) (equalp t2 '(VALUES &REST T)))
(return-from values-type-or t2))
(when (or (eq t1 'T) (equalp t1 '(VALUES &REST T)))
@ -241,7 +241,7 @@
,@(and opt (cons '&optional (nreverse opt)))
,@(and rest (cons '&optional rest)))))))
(defun-equal-cached values-type-and (t1 t2)
(defun-cached values-type-and (t1 t2) type-specifier=
(when (or (eq t2 'T) (equalp t2 '(VALUES &REST T)))
(return-from values-type-and t1))
(when (or (eq t1 'T) (equalp t1 '(VALUES &REST T)))
@ -277,7 +277,7 @@
,@(and opt (cons '&optional (nreverse opt)))
,@(and rest (cons '&optional rest)))))))
(defun-equal-cached type-or (t1 t2)
(defun-cached type-or (t1 t2) type-specifier=
;; FIXME! Should we allow "*" as type name???
(when (or (eq t1 t2) (eq t2 '*))
(return-from type-or t1))

23
src/cmp/cmputil.lsp
View file

@ -436,6 +436,24 @@ comparing circular objects."
(equal-recursive (cdr x) (cdr y) x0 y0 t (ash path-spec 1) (the fixnum (1+ n))))))))
(equal-recursive x y nil nil t 0 -1)))
(defun type-specifier= (x y)
"Compares two type specifiers for syntactic equality."
;; This function only checks if the arguments have the same name
;; (and arguments in case of compound type specifiers) but not if
;; they are aliases of each other. For example (OR REAL COMPLEX) and
;; NUMBER are considered different by this function but are of
;; course semantically equivalent.
;;
;; Note that type specifiers cannot be compared with EQUAL since in
;; eql and member types the arguments have to compared using EQL.
(if (and (consp x) (consp y))
(if (and (member (first x) '(eql member))
(member (first y) '(eql member)))
(every #'eql x y)
(and (type-specifier= (car x) (car y))
(type-specifier= (cdr x) (cdr y))))
(eql x y)))
;; ----------------------------------------------------------------------
;; CACHED FUNCTIONS
;;
@ -447,7 +465,7 @@ comparing circular objects."
(hash-function (case test
(EQ 'SI::HASH-EQ)
(EQL 'SI::HASH-EQL)
((EQUAL EQUAL-WITH-CIRCULARITY) 'SI::HASH-EQUAL)
((EQUAL EQUAL-WITH-CIRCULARITY TYPE-SPECIFIER=) 'SI::HASH-EQUAL)
(t (setf test 'EQUALP) 'SI::HASH-EQUALP))))
`(progn
(defvar ,cache-name
@ -469,8 +487,5 @@ comparing circular objects."
(setf (aref ,cache-name hash) (list ,@lambda-list output))
output))))))))
(defmacro defun-equal-cached (name lambda-list &body body)
`(defun-cached ,name ,lambda-list equal-with-circularity ,@body))
(defun same-fname-p (name1 name2)
(equal name1 name2))