mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-13 21:02:47 -08:00
Code Issues Projects Releases Packages Wiki Activity

SUBTYPEP must abort on finding a complex CONS type, but this should not affect the TYPE-AND and TYPE-OR routines.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2008-12-01 19:38:58 +01:00
parent 346f4993fe
commit 04807f2266
3 changed files with 28 additions and 9 deletions
Download patch file Download diff file Expand all files Collapse all files

4
src/CHANGELOG
View file

@ -177,6 +177,10 @@ ECL 8.9.0:
- ENSURE-DIRECTORIES first has to merge the path with *DEFAULT-PATH...*
- SUBTYPEP does not support complex CONS type specifiers. This caused the
compiler to choke on declaration such as (CONS INTEGER (CONS T T))
and the like.
;;; Local Variables: ***
;;; mode:text ***
;;; fill-column:79 ***

21
src/cmp/cmptype.lsp
View file

@ -143,12 +143,17 @@
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)
(cmpwarn "Unknown type ~S" t1)
(cmpwarn "Unknown type ~S. Assuming it is T." t1)
t2)
(t
(error t2)
(cmpwarn "Unknown type ~S" t2)
(cmpwarn "Unknown type ~S. Assuming it is T." t2)
t1))))
(defun type-or (t1 t2)
@ -172,12 +177,18 @@
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)
(cmpwarn "Unknown type ~S" t1)
'T)
T)
(t
(cmpwarn "Unknown type ~S" t2)
'T))))
T))))
(defun type>= (type1 type2)
(subtypep type2 type1))

12
src/lsp/predlib.lsp
View file

@ -753,8 +753,9 @@ if not possible."
(or (find-registered-tag type)
(multiple-value-bind (tag-super tag-sub)
(find-type-bounds type in-our-family-p type-<= nil)
(let ((tag (logior (new-type-tag) tag-sub)))
(let ((tag (new-type-tag)))
(update-types (logandc2 tag-super tag-sub) tag)
(setf tag (logior tag tag-sub))
(push-type type tag)
tag))))
@ -1064,9 +1065,12 @@ if not possible."
(defun register-cons-type (&optional (car-type '*) (cdr-type '*))
(let ((car-tag (if (eq car-type '*) -1 (canonical-type car-type)))
(cdr-tag (if (eq cdr-type '*) -1 (canonical-type cdr-type))))
(if (or (zerop car-tag) (zerop cdr-tag))
0
(canonical-type 'CONS))))
(cond ((or (zerop car-tag) (zerop cdr-tag))
0)
((and (= car-tag -1) (= cdr-tag -1))
(canonical-type 'CONS))
(t
(throw '+canonical-type-failure+ 'CONS)))))
;;----------------------------------------------------------------------
;; FIND-BUILT-IN-TAG