mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2025-12-05 18:30:24 -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

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

@ -86,37 +86,34 @@
(return-from type-and t1))
(when (eq t1 '*)
(return-from type-and t2))
(let* ((si::*highest-type-tag* si::*highest-type-tag*)
(si::*save-types-database* t)
(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*)))
(cond ((and (numberp tag1) (numberp tag2))
(setf tag1 (si::safe-canonical-type t1 *cmp-env*)
tag2 (si::safe-canonical-type t2 *cmp-env*))
(cond ((zerop (logand tag1 tag2)) ; '(AND t1 t2) = NIL
NIL)
((zerop (logandc2 tag1 tag2)) ; t1 <= t2
t1)
((zerop (logandc2 tag2 tag1)) ; t2 <= t1
t2)
(t
`(AND ,t1 ,t2))))
((eq tag1 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
t2)
((eq tag2 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
t1)
((null tag1)
;(setf c::*compiler-break-enable* t) (break)
(cmpnote "Unknown type ~S. Assuming it is T." t1)
t2)
(t
;(setf c::*compiler-break-enable* t) (break)
(cmpnote "Unknown type ~S. Assuming it is T." t2)
t1))))
(si::with-type-database ()
(let ((tag1 (si::safe-canonical-type t1 *cmp-env*))
(tag2 (si::safe-canonical-type t2 *cmp-env*)))
(cond ((and (numberp tag1) (numberp tag2))
(setf tag1 (si::safe-canonical-type t1 *cmp-env*)
tag2 (si::safe-canonical-type t2 *cmp-env*))
(cond ((zerop (logand tag1 tag2)) ; '(AND t1 t2) = NIL
NIL)
((zerop (logandc2 tag1 tag2)) ; t1 <= t2
t1)
((zerop (logandc2 tag2 tag1)) ; t2 <= t1
t2)
(t
`(AND ,t1 ,t2))))
((eq tag1 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
t2)
((eq tag2 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
t1)
((null tag1)
;(setf c::*compiler-break-enable* t) (break)
(cmpnote "Unknown type ~S. Assuming it is T." t1)
t2)
(t
;(setf c::*compiler-break-enable* t) (break)
(cmpnote "Unknown type ~S. Assuming it is T." t2)
t1)))))
(defun values-number-from-type (type)
(cond ((or (eq type 'T) (eq type '*))
@ -284,35 +281,32 @@
(return-from type-or t1))
(when (eq t1 '*)
(return-from type-or t2))
(let* ((si::*highest-type-tag* si::*highest-type-tag*)
(si::*save-types-database* t)
(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*)))
(cond ((and (numberp tag1) (numberp tag2))
(setf tag1 (si::safe-canonical-type t1 *cmp-env*)
tag2 (si::safe-canonical-type t2 *cmp-env*))
(cond ((zerop (logandc2 tag1 tag2)) ; t1 <= t2
t2)
((zerop (logandc2 tag2 tag1)) ; t2 <= t1
t1)
(t
`(OR ,t1 ,t2))))
((eq tag1 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
T)
((eq tag2 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
T)
((null tag1)
;(break)
(cmpnote "Unknown type ~S" t1)
T)
(t
;(break)
(cmpnote "Unknown type ~S" t2)
T))))
(si::with-type-database ()
(let ((tag1 (si::safe-canonical-type t1 *cmp-env*))
(tag2 (si::safe-canonical-type t2 *cmp-env*)))
(cond ((and (numberp tag1) (numberp tag2))
(setf tag1 (si::safe-canonical-type t1 *cmp-env*)
tag2 (si::safe-canonical-type t2 *cmp-env*))
(cond ((zerop (logandc2 tag1 tag2)) ; t1 <= t2
t2)
((zerop (logandc2 tag2 tag1)) ; t2 <= t1
t1)
(t
`(OR ,t1 ,t2))))
((eq tag1 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
T)
((eq tag2 'CONS)
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
T)
((null tag1)
;(break)
(cmpnote "Unknown type ~S" t1)
T)
(t
;(break)
(cmpnote "Unknown type ~S" t2)
T)))))
(defun type>= (type1 type2 &optional env)
(subtypep type2 type1 env))

24
src/lsp/predlib.lsp
View file

@ -860,6 +860,15 @@ if not possible."
#-ecl-min
'#.*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 ()
(declare (si::c-local))
(prog1 *highest-type-tag*
@ -1436,10 +1445,7 @@ if not possible."
;;
#+ (or)
(defun canonicalize (type env)
(let ((*highest-type-tag* *highest-type-tag*)
(*save-types-database* t)
(*member-types* *member-types*)
(*elementary-types* *elementary-types*))
(with-type-database ()
(let ((tag (canonical-type type env))
(out))
(setq tag (canonical-type type env))
@ -1579,10 +1585,7 @@ if not possible."
(when (and elt (eq (caar elt) t1) (eq (cdar elt) t2))
(setf elt (cdr elt))
(return-from subtypep (values (car elt) (cdr elt))))
(let* ((*highest-type-tag* *highest-type-tag*)
(*save-types-database* t)
(*member-types* *member-types*)
(*elementary-types* *elementary-types*))
(with-type-database ()
(multiple-value-bind (test confident)
(fast-subtypep t1 t2 env)
(setf (aref cache hash) (cons (cons t1 t2) (cons test confident)))
@ -1615,10 +1618,7 @@ if not possible."
(values nil nil)))))
(defun type= (t1 t2 &optional env)
(let ((*highest-type-tag* *highest-type-tag*)
(*save-types-database* t)
(*member-types* *member-types*)
(*elementary-types* *elementary-types*))
(with-type-database ()
(fast-type= t1 t2 env)))
(defun search-type-in-env (type env)