mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-18 07:12:26 -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-11-30 22:28:51 +01:00
parent d7ce7efa81
commit 044caf8c4d
3 changed files with 22 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

8
src/c/file.d
View file

@ -2206,8 +2206,7 @@ io_file_read_vector(cl_object strm, cl_object data, cl_index start, cl_index end
void *aux = data->vector.self.ch + start;
return strm->stream.ops->read_byte8(strm, aux, end-start);
}
}
if (t == aet_fix || t == aet_index) {
} else if (t == aet_fix || t == aet_index) {
if (strm->stream.byte_size == sizeof(cl_fixnum)*8) {
void *aux = data->vector.self.fix + start;
cl_index bytes = (end - start) * sizeof(cl_fixnum);
@ -2229,8 +2228,7 @@ io_file_write_vector(cl_object strm, cl_object data, cl_index start, cl_index en
void *aux = data->vector.self.fix + start;
return strm->stream.ops->write_byte8(strm, aux, end-start);
}
}
if (t == aet_fix || t == aet_index) {
} else if (t == aet_fix || t == aet_index) {
if (strm->stream.byte_size == sizeof(cl_fixnum)*8) {
void *aux = data->vector.self.fix + start;
cl_index bytes = (end - start) * sizeof(cl_fixnum);
@ -2347,6 +2345,8 @@ set_stream_elt_type(cl_object stream, cl_fixnum byte_size, int flags)
case ECL_STREAM_BINARY:
IO_STREAM_ELT_TYPE(stream) = cl_list(2, t, MAKE_FIXNUM(byte_size));
stream->stream.format = @':default';
stream->stream.ops->read_char = not_character_read_char;
stream->stream.ops->write_char = not_character_write_char;
break;
/*case ECL_ISO_8859_1:*/
case ECL_STREAM_LATIN_1:

13
src/cmp/cmptype.lsp
View file

@ -143,12 +143,15 @@
t2)
(t
`(AND ,t1 ,t2))))
((eq tag1 'CONS)
(type-and 'CONS t2))
((eq tag2 'CONS)
(type-and t1 'CONS))
((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,6 +175,10 @@
t1)
(t
`(OR ,t1 ,t2))))
((eq tag1 'CONS)
(type-or 'CONS t2))
((eq tag2 'CONS)
(type-or t1 'CONS))
((null tag1)
(cmpwarn "Unknown type ~S" t1)
'T)

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