mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-06 02:40:26 -08:00
Code Issues Projects Releases Packages Wiki Activity

subtypep: rebind type variables with a macro WITH-TYPE-DATABASE

Browse source 
It seems that some variables were rebound also in cmptype-arith.lsp -- to avoid
potential inconsistency we abstract away bindings as WITH-TYPE-DTABASE.
This commit is contained in:
Daniel Kochmański 2025-08-22 13:06:54 +02:00
parent e8f931c484
commit cfe1dec177
2 changed files with 66 additions and 72 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -86,11 +86,8 @@
(return-from type-and t1)) (return-from type-and t1))
(when (eq t1 '*) (when (eq t1 '*)
(return-from type-and t2)) (return-from type-and t2))
(let* ((si::*highest-type-tag* si::*highest-type-tag*) (si::with-type-database ()
(si::*save-types-database* t) (let ((tag1 (si::safe-canonical-type t1 *cmp-env*))
(si::*member-types* si::*member-types*)
(si::*elementary-types* si::*elementary-types*)
(tag1 (si::safe-canonical-type t1 *cmp-env*))
(tag2 (si::safe-canonical-type t2 *cmp-env*))) (tag2 (si::safe-canonical-type t2 *cmp-env*)))
(cond ((and (numberp tag1) (numberp tag2)) (cond ((and (numberp tag1) (numberp tag2))
(setf tag1 (si::safe-canonical-type t1 *cmp-env*) (setf tag1 (si::safe-canonical-type t1 *cmp-env*)
@ -116,7 +113,7 @@
(t (t
;(setf c::*compiler-break-enable* t) (break) ;(setf c::*compiler-break-enable* t) (break)
(cmpnote "Unknown type ~S. Assuming it is T." t2) (cmpnote "Unknown type ~S. Assuming it is T." t2)
t1)))) t1)))))
(defun values-number-from-type (type) (defun values-number-from-type (type)
(cond ((or (eq type 'T) (eq type '*)) (cond ((or (eq type 'T) (eq type '*))
@ -284,11 +281,8 @@
(return-from type-or t1)) (return-from type-or t1))
(when (eq t1 '*) (when (eq t1 '*)
(return-from type-or t2)) (return-from type-or t2))
(let* ((si::*highest-type-tag* si::*highest-type-tag*) (si::with-type-database ()
(si::*save-types-database* t) (let ((tag1 (si::safe-canonical-type t1 *cmp-env*))
(si::*member-types* si::*member-types*)
(si::*elementary-types* si::*elementary-types*)
(tag1 (si::safe-canonical-type t1 *cmp-env*))
(tag2 (si::safe-canonical-type t2 *cmp-env*))) (tag2 (si::safe-canonical-type t2 *cmp-env*)))
(cond ((and (numberp tag1) (numberp tag2)) (cond ((and (numberp tag1) (numberp tag2))
(setf tag1 (si::safe-canonical-type t1 *cmp-env*) (setf tag1 (si::safe-canonical-type t1 *cmp-env*)
@ -312,7 +306,7 @@
(t (t
;(break) ;(break)
(cmpnote "Unknown type ~S" t2) (cmpnote "Unknown type ~S" t2)
T)))) T)))))
(defun type>= (type1 type2 &optional env) (defun type>= (type1 type2 &optional env)
(subtypep type2 type1 env)) (subtypep type2 type1 env))

24
src/lsp/predlib.lsp
View file

@ -860,6 +860,15 @@ if not possible."
#-ecl-min #-ecl-min
'#.*elementary-types*) '#.*elementary-types*)
;;; INV The function MAYBE-SAVE-TYPES ensures that we operate on fresh conses
;;; instead of modifying *MEMBER-TYPES* and *ELEMENTARY-TYPES*.
(defmacro with-type-database (() &body body)
`(let ((*highest-type-tag* *highest-type-tag*)
(*save-types-database* t)
(*member-types* *member-types*)
(*elementary-types* *elementary-types*))
,@body))
(defun new-type-tag () (defun new-type-tag ()
(declare (si::c-local)) (declare (si::c-local))
(prog1 *highest-type-tag* (prog1 *highest-type-tag*
@ -1436,10 +1445,7 @@ if not possible."
;; ;;
#+ (or) #+ (or)
(defun canonicalize (type env) (defun canonicalize (type env)
(let ((*highest-type-tag* *highest-type-tag*) (with-type-database ()
(*save-types-database* t)
(*member-types* *member-types*)
(*elementary-types* *elementary-types*))
(let ((tag (canonical-type type env)) (let ((tag (canonical-type type env))
(out)) (out))
(setq tag (canonical-type type env)) (setq tag (canonical-type type env))
@ -1579,10 +1585,7 @@ if not possible."
(when (and elt (eq (caar elt) t1) (eq (cdar elt) t2)) (when (and elt (eq (caar elt) t1) (eq (cdar elt) t2))
(setf elt (cdr elt)) (setf elt (cdr elt))
(return-from subtypep (values (car elt) (cdr elt)))) (return-from subtypep (values (car elt) (cdr elt))))
(let* ((*highest-type-tag* *highest-type-tag*) (with-type-database ()
(*save-types-database* t)
(*member-types* *member-types*)
(*elementary-types* *elementary-types*))
(multiple-value-bind (test confident) (multiple-value-bind (test confident)
(fast-subtypep t1 t2 env) (fast-subtypep t1 t2 env)
(setf (aref cache hash) (cons (cons t1 t2) (cons test confident))) (setf (aref cache hash) (cons (cons t1 t2) (cons test confident)))
@ -1615,10 +1618,7 @@ if not possible."
(values nil nil))))) (values nil nil)))))
(defun type= (t1 t2 &optional env) (defun type= (t1 t2 &optional env)
(let ((*highest-type-tag* *highest-type-tag*) (with-type-database ()
(*save-types-database* t)
(*member-types* *member-types*)
(*elementary-types* *elementary-types*))
(fast-type= t1 t2 env))) (fast-type= t1 t2 env)))
(defun search-type-in-env (type env) (defun search-type-in-env (type env)