26 |
*/ |
*/ |
27 |
|
|
28 |
#include "include.h" |
#include "include.h" |
29 |
|
#include "num_include.h" |
30 |
|
|
31 |
static int reverse_comparison; |
#define TARG1(a,b) (reverse_comparison!=Cnil ? (b) : (a)) |
32 |
|
#define TARG2(a,b) (reverse_comparison!=Cnil ? (a) : (b)) |
|
#define TARG1(a,b) (reverse_comparison ? (b) : (a)) |
|
|
#define TARG2(a,b) (reverse_comparison ? (a) : (b)) |
|
33 |
|
|
34 |
object sKinitial_element; |
object sKinitial_element; |
35 |
|
|
38 |
#define saveTEST \ |
#define saveTEST \ |
39 |
object old_test_function = test_function; \ |
object old_test_function = test_function; \ |
40 |
object old_item_compared = item_compared; \ |
object old_item_compared = item_compared; \ |
41 |
|
object old_reverse_comparison = reverse_comparison; \ |
42 |
bool (*old_tf)() = tf; \ |
bool (*old_tf)() = tf; \ |
43 |
object old_key_function = key_function; \ |
object old_key_function = key_function; \ |
44 |
object (*old_kf)() = kf; \ |
object (*old_kf)() = kf; \ |
56 |
frs_pop(); \ |
frs_pop(); \ |
57 |
test_function = old_test_function; \ |
test_function = old_test_function; \ |
58 |
item_compared = old_item_compared; \ |
item_compared = old_item_compared; \ |
59 |
|
reverse_comparison = old_reverse_comparison; \ |
60 |
tf = old_tf; \ |
tf = old_tf; \ |
61 |
key_function = old_key_function; \ |
key_function = old_key_function; \ |
62 |
kf = old_kf; \ |
kf = old_kf; \ |
115 |
} |
} |
116 |
|
|
117 |
static void |
static void |
118 |
setupTEST(item, test, test_not, key) |
setupTEST(item, test, test_not, key, rev) |
119 |
object item, test, test_not, key; |
object item, test, test_not, key, rev; |
120 |
{ |
{ |
121 |
item_compared = item; |
item_compared = item; |
122 |
if (test != Cnil) { |
if (test != Cnil) { |
134 |
kf = apply_key_function; |
kf = apply_key_function; |
135 |
} else |
} else |
136 |
kf = identity; |
kf = identity; |
137 |
|
reverse_comparison=rev; |
138 |
} |
} |
139 |
|
|
140 |
#define PREDICATE(f, f_if, f_if_not, n) \ |
#define PREDICATE(f, f_if, f_if_not, n) \ |
518 |
object x; |
object x; |
519 |
cs_check(alist); |
cs_check(alist); |
520 |
|
|
|
|
|
521 |
for (x = alist; !endp(x); x = x->c.c_cdr) { |
for (x = alist; !endp(x); x = x->c.c_cdr) { |
522 |
item_compared = car(x->c.c_car); |
item_compared = car(x->c.c_car); |
523 |
if (TEST(tree)) { |
if (TEST(tree)) { |
695 |
saveTEST; |
saveTEST; |
696 |
@ |
@ |
697 |
protectTEST; |
protectTEST; |
698 |
setupTEST(Cnil, test, test_not, Cnil); |
setupTEST(Cnil, test, test_not, Cnil, Cnil); |
699 |
x=(tree_equal(x, y) ? Ct : Cnil); |
x=(tree_equal(x, y) ? Ct : Cnil); |
700 |
restoreTEST; |
restoreTEST; |
701 |
@(return x) |
@(return x) |
796 |
if (endp(vs_base[0])) |
if (endp(vs_base[0])) |
797 |
return; |
return; |
798 |
if (n==2) { |
if (n==2) { |
799 |
if (type_of(vs_base[1])!=t_fixnum || (n=fix(vs_base[1]))<0) |
enum type tp=type_of(vs_base[1]); |
800 |
FEwrong_type_argument(sLnon_negative_fixnum,vs_base[1]); |
if ((tp!=t_fixnum && tp!=t_bignum)|| number_minusp(vs_base[1])) |
801 |
vs_popp; |
TYPE_ERROR(vs_base[1],list(2,sLinteger,make_fixnum(0))); |
802 |
|
n=tp==t_fixnum ? fix(vs_base[1]) : MOST_POSITIVE_FIX; |
803 |
|
vs_popp; |
804 |
} |
} |
805 |
|
|
806 |
if (!n) |
if (!n) |
1065 |
saveTEST; |
saveTEST; |
1066 |
@ |
@ |
1067 |
protectTEST; |
protectTEST; |
1068 |
setupTEST(old, test, test_not, key); |
setupTEST(old, test, test_not, key, Cnil); |
1069 |
subst(new, tree); |
subst(new, tree); |
1070 |
tree = vs_pop; |
tree = vs_pop; |
1071 |
restoreTEST; |
restoreTEST; |
1079 |
saveTEST; |
saveTEST; |
1080 |
@ |
@ |
1081 |
protectTEST; |
protectTEST; |
1082 |
setupTEST(old, test, test_not, key); |
setupTEST(old, test, test_not, key, Cnil); |
1083 |
nsubst(new, &tree); |
nsubst(new, &tree); |
1084 |
restoreTEST; |
restoreTEST; |
1085 |
@(return tree) |
@(return tree) |
1130 |
*/ |
*/ |
1131 |
for (v=alist ; consp(v) ; v=v->c.c_cdr); |
for (v=alist ; consp(v) ; v=v->c.c_cdr); |
1132 |
if (v != Cnil) |
if (v != Cnil) |
1133 |
FEwrong_type_argument(sLlist, alist); |
TYPE_ERROR(alist,siLproper_list); |
1134 |
} |
} |
1135 |
|
|
1136 |
|
|
1139 |
saveTEST; |
saveTEST; |
1140 |
@ |
@ |
1141 |
protectTEST; |
protectTEST; |
1142 |
setupTEST(Cnil, test, test_not, key); |
setupTEST(Cnil, test, test_not, key, Ct); |
1143 |
sublis(alist, tree); |
sublis(alist, tree); |
1144 |
tree = vs_pop; |
tree = vs_pop; |
1145 |
restoreTEST; |
restoreTEST; |
1150 |
saveTEST; |
saveTEST; |
1151 |
@ |
@ |
1152 |
protectTEST; |
protectTEST; |
1153 |
setupTEST(Cnil, test, test_not, key); |
setupTEST(Cnil, test, test_not, key, Ct); |
1154 |
nsublis(alist, &tree); |
nsublis(alist, &tree); |
1155 |
restoreTEST; |
restoreTEST; |
1156 |
@(return tree) |
@(return tree) |
1161 |
|
|
1162 |
@ |
@ |
1163 |
protectTEST; |
protectTEST; |
1164 |
setupTEST(item, test, test_not, key); |
setupTEST(item, test, test_not, key, Cnil); |
1165 |
while (!endp(list)) { |
while (!endp(list)) { |
1166 |
if (TEST(list->c.c_car)) |
if (TEST(list->c.c_car)) |
1167 |
goto L; |
goto L; |
1179 |
protectTEST; |
protectTEST; |
1180 |
if (key != Cnil) |
if (key != Cnil) |
1181 |
item = ifuncall1(key, item); |
item = ifuncall1(key, item); |
1182 |
if (rev != Cnil) |
setupTEST(item, test, test_not, key, rev); |
|
reverse_comparison=1; |
|
|
setupTEST(item, test, test_not, key); |
|
1183 |
while (!endp(list)) { |
while (!endp(list)) { |
1184 |
if (TEST(list->c.c_car)) |
if (TEST(list->c.c_car)) |
1185 |
goto L; |
goto L; |
1186 |
list = list->c.c_cdr; |
list = list->c.c_cdr; |
1187 |
} |
} |
1188 |
restoreTEST; |
restoreTEST; |
|
reverse_comparison=0; |
|
1189 |
@(return list) |
@(return list) |
1190 |
@) |
@) |
1191 |
|
|
1258 |
saveTEST; |
saveTEST; |
1259 |
@ |
@ |
1260 |
protectTEST; |
protectTEST; |
1261 |
setupTEST(item, test, test_not, key); |
setupTEST(item, test, test_not, key, Cnil); |
1262 |
while (!endp(a_list)) { |
while (!endp(a_list)) { |
1263 |
if (a_list->c.c_car != Cnil && |
if (a_list->c.c_car != Cnil && |
1264 |
TEST((*car_or_cdr)(a_list->c.c_car))) { |
TEST((*car_or_cdr)(a_list->c.c_car))) { |