mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2025-12-05 18:30:24 -08:00
subtypep: rebind type variables with a macro WITH-TYPE-DATABASE
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
parent
e8f931c484
commit
cfe1dec177
2 changed files with 66 additions and 72 deletions
|
|
@ -86,37 +86,34 @@
|
||||||
(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*)
|
(tag2 (si::safe-canonical-type t2 *cmp-env*)))
|
||||||
(si::*elementary-types* si::*elementary-types*)
|
(cond ((and (numberp tag1) (numberp tag2))
|
||||||
(tag1 (si::safe-canonical-type t1 *cmp-env*))
|
(setf 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 ((zerop (logand tag1 tag2)) ; '(AND t1 t2) = NIL
|
||||||
(setf tag1 (si::safe-canonical-type t1 *cmp-env*)
|
NIL)
|
||||||
tag2 (si::safe-canonical-type t2 *cmp-env*))
|
((zerop (logandc2 tag1 tag2)) ; t1 <= t2
|
||||||
(cond ((zerop (logand tag1 tag2)) ; '(AND t1 t2) = NIL
|
t1)
|
||||||
NIL)
|
((zerop (logandc2 tag2 tag1)) ; t2 <= t1
|
||||||
((zerop (logandc2 tag1 tag2)) ; t1 <= t2
|
t2)
|
||||||
t1)
|
(t
|
||||||
((zerop (logandc2 tag2 tag1)) ; t2 <= t1
|
`(AND ,t1 ,t2))))
|
||||||
t2)
|
((eq tag1 'CONS)
|
||||||
(t
|
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
|
||||||
`(AND ,t1 ,t2))))
|
t2)
|
||||||
((eq tag1 'CONS)
|
((eq tag2 'CONS)
|
||||||
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
|
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
|
||||||
t2)
|
t1)
|
||||||
((eq tag2 'CONS)
|
((null tag1)
|
||||||
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
|
;(setf c::*compiler-break-enable* t) (break)
|
||||||
t1)
|
(cmpnote "Unknown type ~S. Assuming it is T." t1)
|
||||||
((null tag1)
|
t2)
|
||||||
;(setf c::*compiler-break-enable* t) (break)
|
(t
|
||||||
(cmpnote "Unknown type ~S. Assuming it is T." t1)
|
;(setf c::*compiler-break-enable* t) (break)
|
||||||
t2)
|
(cmpnote "Unknown type ~S. Assuming it is T." t2)
|
||||||
(t
|
t1)))))
|
||||||
;(setf c::*compiler-break-enable* t) (break)
|
|
||||||
(cmpnote "Unknown type ~S. Assuming it is T." t2)
|
|
||||||
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,35 +281,32 @@
|
||||||
(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*)
|
(tag2 (si::safe-canonical-type t2 *cmp-env*)))
|
||||||
(si::*elementary-types* si::*elementary-types*)
|
(cond ((and (numberp tag1) (numberp tag2))
|
||||||
(tag1 (si::safe-canonical-type t1 *cmp-env*))
|
(setf 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 ((zerop (logandc2 tag1 tag2)) ; t1 <= t2
|
||||||
(setf tag1 (si::safe-canonical-type t1 *cmp-env*)
|
t2)
|
||||||
tag2 (si::safe-canonical-type t2 *cmp-env*))
|
((zerop (logandc2 tag2 tag1)) ; t2 <= t1
|
||||||
(cond ((zerop (logandc2 tag1 tag2)) ; t1 <= t2
|
t1)
|
||||||
t2)
|
(t
|
||||||
((zerop (logandc2 tag2 tag1)) ; t2 <= t1
|
`(OR ,t1 ,t2))))
|
||||||
t1)
|
((eq tag1 'CONS)
|
||||||
(t
|
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
|
||||||
`(OR ,t1 ,t2))))
|
T)
|
||||||
((eq tag1 'CONS)
|
((eq tag2 'CONS)
|
||||||
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t1)
|
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
|
||||||
T)
|
T)
|
||||||
((eq tag2 'CONS)
|
((null tag1)
|
||||||
(cmpwarn "Unsupported CONS type ~S. Replacing it with T." t2)
|
;(break)
|
||||||
T)
|
(cmpnote "Unknown type ~S" t1)
|
||||||
((null tag1)
|
T)
|
||||||
;(break)
|
(t
|
||||||
(cmpnote "Unknown type ~S" t1)
|
;(break)
|
||||||
T)
|
(cmpnote "Unknown type ~S" t2)
|
||||||
(t
|
T)))))
|
||||||
;(break)
|
|
||||||
(cmpnote "Unknown type ~S" t2)
|
|
||||||
T))))
|
|
||||||
|
|
||||||
(defun type>= (type1 type2 &optional env)
|
(defun type>= (type1 type2 &optional env)
|
||||||
(subtypep type2 type1 env))
|
(subtypep type2 type1 env))
|
||||||
|
|
|
||||||
|
|
@ -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)
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue