diff --git a/src/cmp/cmptype-arith.lsp b/src/cmp/cmptype-arith.lsp index 68c33c325..f2d0c0ff9 100644 --- a/src/cmp/cmptype-arith.lsp +++ b/src/cmp/cmptype-arith.lsp @@ -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)) diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index acbc8f1e5..9bed9e2ef 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -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)