From 019579dd46beb0def5c831b753f4b41d0e6522dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Daniel=20Kochma=C5=84ski?= Date: Tue, 11 Jul 2023 18:05:46 +0200 Subject: [PATCH] subtypep: use constants for hardcoded tags for T and NIL +BUILT-IN-TYPE-NIL+ and +BUILT-IN-TYPE-t+ are bottom and top types of the common lisp type system. They were sometimes refered in the code as naked integers - we change that by defining constants to better convey the meaning. --- src/lsp/predlib.lsp | 105 +++++++++++++++++++++++++------------------- 1 file changed, 60 insertions(+), 45 deletions(-) diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index ddaf53b68..21b0aeb3b 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -805,34 +805,38 @@ if not possible." (t (fail)))))) -;;************************************************************ -;; SUBTYPEP -;;************************************************************ -;; -;; TYPES LATTICE (Following Henry Baker's paper) -;; -;; The algorithm works as follows. Types are identified with sets. Some sets -;; are elementary, in the sense that other types may be expressed as -;; combination of them. We partition these sets into FAMILIES -;; -;; Built-in objects --- Hash tables, etc -;; Intervals --- (INTEGER a b), (REAL a b), etc -;; Arrays --- (ARRAY * (2)), etc -;; Classes -;; -;; When passed a type specifier, ECL canonicalizes it: it decomposes the -;; type into the most elementary sets, assigns a unique bit pattern (TAG) to -;; each of these sets, and builds a composite tag for the type by LOGIOR. -;; Operations between these sets reduce to logical operations between these -;; bit patterns. Given types T1, T2 and a function which produces tags f(T) -;; -;; f((AND T1 T2)) = (LOGIAND f(T1) f(T2)) -;; f((OR T1 T2)) = (LOGIOR f(T1) f(T2)) -;; f((NOT T1)) = (LOGNOT f(T2)) -;; -;; However, tags are not permanent: whenever a new type is registered, the -;; tag associated to a type may be changed (for instance, because new -;; elementary sets are discovered, which also belong to existing types). +;;; ---------------------------------------------------------------------------- +;;; SUBTYPEP +;;; ---------------------------------------------------------------------------- +;;; +;;; TYPES LATTICE +;;; +;;; Following the paper written by Henry G. Baker: "A Decision Procedure for +;;; Common Lisp's SUBTYPEP Predicate". +;;; +;;; The algorithm works as follows. Types are identified with sets. Some sets +;;; are elementary, in the sense that other types may be expressed as +;;; combination of them. We partition these sets into FAMILIES (kingdoms): +;;; +;;; Built-in objects --- Hash tables, etc +;;; Intervals --- (INTEGER a b), (REAL a b), etc +;;; Arrays --- (ARRAY * (2)), etc +;;; Classes +;;; +;;; When passed a type specifier, ECL canonicalizes it: it decomposes the type +;;; into the most elementary sets, assigns a unique bit pattern (TAG) to each +;;; of these sets, and builds a composite tag for the type by LOGIOR. +;;; Operations between these sets reduce to logical operations between these +;;; bit patterns. Given types T1, T2 and a function which produces tags f(T) +;;; +;;; f((AND T1 T2)) = (LOGIAND f(T1) f(T2)) +;;; f((OR T1 T2)) = (LOGIOR f(T1) f(T2)) +;;; f((NOT T1)) = (LOGNOT f(T1)) +;;; +;;; However, tags are not permanent: whenever a new type is registered, the +;;; tag associated to a type may be changed (for instance, because new +;;; elementary sets are discovered, which also belong to existing types). +;;; ---------------------------------------------------------------------------- (defparameter *save-types-database* nil) @@ -840,6 +844,10 @@ if not possible." #+ecl-min #B1 #-ecl-min '#.*highest-type-tag*) +;;; Built-in tags for the top and the bottom types. +(defconstant +built-in-tag-t+ -1) +(defconstant +built-in-tag-nil+ 0) + (defparameter *member-types* #+ecl-min NIL #-ecl-min '#.*member-types*) @@ -903,9 +911,9 @@ if not possible." (declare (si::c-local) (optimize (safety 0)) (function in-our-family-p type-<=)) - (let* ((subtype-tag 0) - (disjoint-tag 0) - (supertype-tag (if minimize-super -1 0))) + (let ((subtype-tag +built-in-tag-nil+) + (disjoint-tag +built-in-tag-nil+) + (supertype-tag (if minimize-super +built-in-tag-t+ +built-in-tag-nil+))) (dolist (i *elementary-types*) (declare (cons i)) (let ((other-type (car i)) @@ -920,7 +928,8 @@ if not possible." (setq subtype-tag (logior other-tag subtype-tag))) (t (setq disjoint-tag (logior disjoint-tag other-tag))))))) - (values (if (= supertype-tag -1) 0 + (values (if (= supertype-tag +built-in-tag-t+) + +built-in-tag-nil+ (logandc2 supertype-tag (logior disjoint-tag subtype-tag))) subtype-tag))) @@ -1028,7 +1037,9 @@ if not possible." (and (not (clos::class-finalized-p class)) (throw '+canonical-type-failure+ nil)) (register-type class - #'(lambda (c) (or (si::instancep c) (symbolp c))) + #'(lambda (c) + (or (si::instancep c) + (symbolp c))) #'(lambda (c1 c2) (when (symbolp c1) (setq c1 (find-class c1 nil))) @@ -1044,12 +1055,13 @@ if not possible." (multiple-value-bind (array-class elt-type dimensions) (parse-array-type type env) (cond ((eq elt-type '*) - (canonical-type `(OR ,@(mapcar #'(lambda (type) `(,array-class ,type ,dimensions)) + (canonical-type `(OR ,@(mapcar #'(lambda (type) + `(,array-class ,type ,dimensions)) +upgraded-array-element-types+)) env)) ((find-registered-tag (setq type (list array-class elt-type dimensions)))) (t - #+nil + #+ (or) (when (and (consp dimensions) (> (count-if #'numberp dimensions) 1)) (dotimes (i (length dimensions)) (when (numberp (elt dimensions i)) @@ -1132,6 +1144,7 @@ if not possible." ;; Arbitrary intervals may be defined as the union or intersection of ;; semi-infinite intervals, of the form (number-type b *), where B is ;; either a real number, a list with one real number or *. +;; ;; Any other interval, may be defined using these. For instance ;; (INTEGER 0 2) = (AND (INTEGER 0 *) (NOT (INTEGER (2) *))) ;; (SHORT-FLOAT (0.2) (2)) = (AND (SHORT-FLOAT (0.2) *) (NOT (SHORT-FLOAT 2 *))) @@ -1161,7 +1174,7 @@ if not possible." (low (if i (pop i) '*)) (high (if i (pop i) '*)) (tag-high (cond ((eq high '*) - 0) + +built-in-tag-nil+) ((eq type 'INTEGER) (setq high (if (consp high) (ceiling (first high)) @@ -1261,11 +1274,11 @@ if not possible." ;; of whether the arguments are valid types or not! #+(or) (canonical-type 'CONS env) - (let ((car-tag (if (eq car-type '*) -1 (canonical-type car-type env))) - (cdr-tag (if (eq cdr-type '*) -1 (canonical-type cdr-type env)))) - (cond ((or (zerop car-tag) (zerop cdr-tag)) - 0) - ((and (= car-tag -1) (= cdr-tag -1)) + (let ((car-tag (if (eq car-type '*) +built-in-tag-t+ (canonical-type car-type env))) + (cdr-tag (if (eq cdr-type '*) +built-in-tag-t+ (canonical-type cdr-type env)))) + (cond ((or (= car-tag +built-in-tag-nil+) (= cdr-tag +built-in-tag-nil+)) + +built-in-tag-nil+) + ((and (= car-tag +built-in-tag-t+) (= cdr-tag +built-in-tag-t+)) (canonical-type 'CONS env)) (t (throw '+canonical-type-failure+ 'CONS))))) @@ -1392,7 +1405,9 @@ if not possible." (declare (si::c-local)) (let (record) (cond ((eq name T) - -1) + +built-in-tag-t+) + ((eq name NIL) + +built-in-tag-nil+) ((eq (setf record (gethash name +built-in-types+ name)) name) nil) @@ -1423,7 +1438,7 @@ if not possible." ;; readable representation of the type in terms of elementary types, ;; intervals, arrays and classes. ;; -#+nil +#+ (or) (defun canonicalize (type env) (let ((*highest-type-tag* *highest-type-tag*) (*save-types-database* t) @@ -1458,8 +1473,8 @@ if not possible." (when env (setf type (search-type-in-env type env))) (cond ((find-registered-tag type)) - ((eq type 'T) -1) - ((eq type 'NIL) 0) + ((eq type 'T) +built-in-tag-t+) + ((eq type 'NIL) +built-in-tag-nil+) ((symbolp type) (let ((expander (get-sysprop type 'DEFTYPE-DEFINITION))) (cond (expander