mirror of
https://gitlab.com/embeddable-common-lisp/ecl.git
synced 2025-12-05 18:30:24 -08:00
Merge branch 'cons-kingdom' into 'develop'
Cleanups and fixes for SUBTYPEP See merge request embeddable-common-lisp/ecl!357
This commit is contained in:
Marius Gerbershagen
commit
294da20f38
4 changed files with 503 additions and 444 deletions
|
|
@ -653,12 +653,10 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes)
|
|||
Checks the stack frame for keyword arguments.
|
||||
*/
|
||||
CASE(OP_PUSHKEYS); {
|
||||
cl_object keys_list, aok, *first, *last;
|
||||
cl_index count;
|
||||
cl_object keys_list, aok, *ptr, *end;
|
||||
cl_index count, limit;
|
||||
GET_DATA(keys_list, vector, data);
|
||||
first = ECL_STACK_FRAME_PTR(frame) + frame_index;
|
||||
count = frame->frame.size - frame_index;
|
||||
last = first + count;
|
||||
limit = count = frame->frame.size - frame_index;
|
||||
if (ecl_unlikely(count & 1)) {
|
||||
VEbad_lambda_odd_keys(bytecodes, frame);
|
||||
}
|
||||
|
|
@ -667,28 +665,32 @@ ecl_interpret(cl_object frame, cl_object closure, cl_object bytecodes)
|
|||
cl_object name = ECL_CONS_CAR(keys_list);
|
||||
cl_object flag = ECL_NIL;
|
||||
cl_object value = ECL_NIL;
|
||||
cl_object *p = first;
|
||||
for (; p != last; ++p) {
|
||||
if (*(p++) == name) {
|
||||
ptr = ECL_STACK_FRAME_PTR(frame) + frame_index;
|
||||
end = ptr + limit;
|
||||
for (; ptr != end; ptr++) {
|
||||
if (*(ptr++) == name) {
|
||||
count -= 2;
|
||||
if (flag == ECL_NIL) {
|
||||
flag = ECL_T;
|
||||
value = *p;
|
||||
value = *ptr;
|
||||
}
|
||||
}
|
||||
}
|
||||
/* Pushing to the stack may resize it, so be careful to reinitialize
|
||||
pointers using the new value of ECL_STACK_FRAME_PTR. */
|
||||
if (flag != ECL_NIL) ECL_STACK_PUSH(the_env, value);
|
||||
ECL_STACK_PUSH(the_env, flag);
|
||||
}
|
||||
if (count && Null(aok)) {
|
||||
cl_object *p = first;
|
||||
for (; p != last; ++p) {
|
||||
if (*(p++) == @':allow-other-keys') {
|
||||
aok = *p;
|
||||
ptr = ECL_STACK_FRAME_PTR(frame) + frame_index;
|
||||
end = ptr + limit;
|
||||
for (; ptr != end; ptr++) {
|
||||
if (*(ptr++) == @':allow-other-keys') {
|
||||
aok = *ptr;
|
||||
count -= 2;
|
||||
/* only the first :allow-other-keys argument is considered */
|
||||
for (++p; p != last; ++p) {
|
||||
if (*(p++) != @':allow-other-keys')
|
||||
for (ptr++; ptr != end; ptr++) {
|
||||
if (*(ptr++) != @':allow-other-keys')
|
||||
break;
|
||||
count -= 2;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -392,7 +392,6 @@ ecl_bds_overflow(void)
|
|||
cl_env_ptr env = ecl_process_env();
|
||||
cl_index margin = ecl_option_values[ECL_OPT_BIND_STACK_SAFETY_AREA];
|
||||
cl_index size = env->bds_stack.size;
|
||||
cl_index limit_size = env->bds_stack.limit_size;
|
||||
ecl_bds_ptr org = env->bds_stack.org;
|
||||
ecl_bds_ptr last = org + size;
|
||||
if (env->bds_stack.limit >= last) {
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load diff
Loading…
Add table
Add a link
Reference in a new issue